' 此程序批处理同一个文件夹中的所有xls文件

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0)    Then
        IsCScript =    True
    Else
        IsCScript =    False
    End    If
End    Function
'------------------------------------------------------------
' 强制在CScript下运行。如果在WScript下运行，退出，强制用Script重新解释运行
Sub    ForceInCScript()
    Dim    WshShell
    Set    WshShell = WScript.CreateObject("WScript.Shell")
   
    If (Not    IsCScript()) Then
       If WScript.Arguments.Count = 0 Then
            WshShell.Run "CScript.exe "    & """" & WScript.ScriptFullName    & """"
        Else
            WshShell.Run "CScript.exe "    & """" & WScript.ScriptFullName    & """ " & WScript.Arguments.Item(0)
        End If
        WScript.Quit ' Terminate script.
    End    If
End    Sub

' 强制在CScript下执行
' 如果需要编译成exe，必须注释掉这句。
ForceInCScript

WScript.Echo "批处理Excel文件程序"
WScript.Echo "------------------------------------------"
WScript.Echo "arcqiufeng@              2017-04-10"
WScript.Echo "------------------------------------------"

' 定义常用计数变量
Dim    i,j,k,c

Dim    fso, f,    ff,    file, ScriptFolder
Set    fso    = CreateObject("Scripting.FileSystemObject")
Set    f =    fso.GetFile(WScript.ScriptFullName)
ScriptFolder = fso.getParentFolderName(f)

' ---------------创建ket或Excel－－－－－－－－－
Dim    Excel
' 忽略错误
On Error Resume    Next
' 尝试创建Excel程序   
Set    Excel =    CreateObject("Excel.Application")
If Excel Is    Nothing    Then '    创建Excel失败。可能Excel没有安装
    Set    Excel =    CreateObject("KET.Application") '尝试创建ET
    If Excel Is    Nothing    Then '    两者都失败，退出
        MsgBox "KET或Excel未安装，需首先安装KET或Excel。", vbInformation,    "注意"
        WScript.Quit
    End    If
End    If
' 恢复错误处理
On Error Goto 0

' 创建统计表
Dim    workbook, worksheet
Set    workbook = Excel.WorkBooks.add

Excel.Visible =    True

Set wb = Excel.workbooks.open(ScriptFolder & "\修改数据.xlsx")
Dim d
Set d = CreateObject("scripting.dictionary")
i =2
Do While Trim(wb.activesheet.cells(i,1).Value)<>""
    wscript.echo wb.activesheet.cells(i,1) & "->" & wb.activesheet.cells(i,2)
    d(wb.activesheet.cells(i,1).Value & ".xls")=wb.activesheet.cells(i,2).Value
    i=i+1
Loop
wb.close

For    Each datafile In d.keys
    Set    wb = Excel.workbooks.open(ScriptFolder & "\" & datafile)
    fn = GetFilenameWithoutExtension(fso.GetFile(datafile).Name)
    WScript.echo "读取 " & fn & "..."

    wb.activesheet.range("C29") = d(datafile)
    wb.save
    wb.close
Next


' --------- 程序结束

Function AddBackslash(ThisFolderPath)
    If Not Right(ThisFolderPath,1) = "\" Then
        ThisFolderPath = ThisFolderPath & "\"
    End If
    AddBackslash = ThisFolderPath
End Function

Function BrowseFolder( myStartLocation, blnSimpleDialog )
' This function generates a Browse Folder dialog
' and returns the selected folder as a string.
'
' Arguments:
' myStartLocation   [string]  start folder for dialog, or "My Computer", or
'                             empty string to open in "Desktop\My Documents"
' blnSimpleDialog   [boolean] if False, an additional text field will be
'                             displayed where the folder can be selected
'                             by typing the fully qualified path
'
' Returns:          [string]  the fully qualified path to the selected folder
'
' Based on the Hey Scripting Guys article
' "How Can I Show Users a Dialog Box That Only Lets Them Select Folders?"
' http://www.
'
' Function written by Rob van der Woude
' http://www.
    Const MY_COMPUTER   = &H11&
    Const WINDOW_HANDLE = 0 ' Must ALWAYS be 0

    Dim numOptions, objFolder, objFolderItem
    Dim objPath, objShell, strPath, strPrompt

    ' Set the options for the dialog window
    strPrompt = "请选择数据文件所在的文件夹:"
    If blnSimpleDialog = True Then
        numOptions = 0      ' Simple dialog
    Else
        numOptions = &H10&  ' Additional text field to type folder path
    End If
   
    ' Create a Windows Shell object
    Set objShell = CreateObject( "Shell.Application" )

    ' If specified, convert "My Computer" to a valid
    ' path for the Windows Shell's BrowseFolder method
    If UCase( myStartLocation ) = "MY COMPUTER" Then
        Set objFolder = objShell.Namespace( MY_COMPUTER )
        Set objFolderItem = objFolder.Self
        strPath = objFolderItem.Path
    Else
        strPath = myStartLocation
    End If

    Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, strPrompt, _
                                              numOptions, strPath )

    ' Quit if no folder was selected
    If objFolder Is Nothing Then
        BrowseFolder = ""
        Exit Function
    End If

    ' Retrieve the path of the selected folder
    Set objFolderItem = objFolder.Self
    objPath = objFolderItem.Path

    ' Return the path of the selected folder
    BrowseFolder = objPath
End Function


Function GetFilenameWithoutExtension(ByVal FileName)
  Dim Result, i
  Result = FileName
  i = InStrRev(FileName, ".")
  If ( i > 0 ) Then
    Result = Mid(FileName, 1, i - 1)
  End If
  GetFilenameWithoutExtension = Result
End Function
   
MsgBox "完成。", vbInformation

这是百度到的一个可以按清单内容 批量写入多个excel中C29单元格内容的VBS  但是只会应用打开excel时候显示的那一个Sheet
但是需要修改的excel Sheet页较多 无法保证每个都是第一页  能否修改成只应用于第一个Sheet

    wb.activesheet.range("C29") = d(datafile)
这句修改一下
    wb.sheet(1).range("C29") = d(datafile)
好像是写1，忘掉了。如果1不对，那就是0 了，

activesheet 当前活动的 工作表
sheet（1） 第一个工作表

另外，KET.Application 不对吧。我用的是
ET.Application
也许 WPS 的版本不同造成的。