之前的【工作拾遗2 VBA工具实现Module和Sheet的拷贝及按钮绑定宏】使用VBA实现的多文件相互sheet拷贝。在实践中，发现文件的数量越多，文件的大小越大，VBA工具越不稳定。经常会出现各种奇怪的问题。出现问题的时候， 就需要手工干预。这主要是因为VBA不够稳定，而且非常耗费内存。更改为VBScript后，性能问题大为改善。 基本不需要人工干预了。

涉及到的功能使用VBS操作Excel的Sheet，Module，打开，保存，关闭等输出log取得当前文件夹文件的基本操作，追加模式，建立文件，判断存在，删除等

可参照之前的VBA实现的相同功能，对比一下不同。另外有一些对象没有关闭，虽不影响执行，但是会产生一些内存垃圾。作者比较懒，先不修正了。

代码

 ' 标注必须显示声明各种变量 Option Explicit ' 声明变量的时候，不需要类型。否则会出编译错误 Dim objExcel Dim currentPath Dim templateWorkbook Dim jsonConverter Dim loadAdip Dim util Dim objFSO Dim objLogfile  ' 建立很常用的fso对象，用来操作普通文件 Set objFSO = CreateObject("Scripting.FileSystemObject") ' 建立Excel对象 Set objExcel = CreateObject("Excel.Application")  ' 取得当前文件夹 currentPath = objFSO.GetFolder(".").Path ' 追加模式打开/建立log文件 Set objLogfile = objFSO.OpenTextFile(currentPath & "\AddDDSheet.log", 8, True)  ' 上一章讲过，不显示警告对话框 objExcel.DisplayAlerts = False ' 输出log writeLog objLogfile, "############## Start ##############"  ' 取得需要拷贝的Sheet存在的模板文件  Set templateWorkbook = objExcel.Workbooks.Open(currentPath & "CopyFrom.xlsm")  ' 取得需要拷贝的Module，从文件中导出到当前文件夹 module1 = currentPath & "\module1.bas" templateWorkbook.VBProject.VBComponents("module1").Export jsonConverter  ' 递归调用sub，实现将Sheet和Module拷贝到当前文件夹\files下所有Excel文件中 ' 这里需要注意，只有扩展名为xlsm的Excel文件才能接收Module LoopAllSubFolders currentPath & "\files", templateWorkbook  ' 关闭模板文件 templateWorkbook.Close() ' 将刚才导出的module删除 If IsExitAFile(module1) Then DeleteAFile(module1) END if  objExcel.DisplayAlerts = True Set objExcel = nothing writeLog objLogfile, "############## End ##############" objLogfile.close() Set objFSO = Nothing Set objLogfile = Nothing msgbox("Execution over")' 递归调用的sub，也是主要功能模块Sub LoopAllSubFolders(folderPath, template) Dim fileName Dim fullFilePath Dim tempWorkbook Dim tempWorksheet Dim currentPath  Dim fso Dim folder Dim files Dim basefolder Dim subFolders Dim file  If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"  Set fso = CreateObject("Scripting.FileSystemObject") Set basefolder = fso.GetFolder(folderPath) For Each file In basefolder.files fileName = file.Name ' excel files only If Right(fileName, 5) = ".xlsx" Or Right(fileName, 5) = ".xlsm" Then  Set tempWorkbook = objExcel.Workbooks.Open(folderPath & fileName)  Dim isExist isExist = False  If worksheetExists("EventDefinition", tempWorkbook) Or worksheetExists("DBMapping(R)", tempWorkbook) Or _ worksheetExists("DBMapping(CUD)", tempWorkbook) Or worksheetExists("Master", tempWorkbook) Then isExist = True End If  If isExist Then tempWorkbook.Close Else  Dim module1 module1 = currentPath & "\module1.bas"  ' 导入module到目标文件 If IsExitAFile(module1) Then tempWorkbook.VBProject.VBComponents.Import module1  ' 拷贝多个Sheet到目标文件 ' 这里要注意，Copy方法有两个参数，第一个是Before，第二个是After，想指定拷贝到某个Sheet之前，需要用第一个， 否则需要用第二个。 这里用的第二个， 所以第一个参数是空的，第二个参数和空的第一个参数之间用逗号间隔 template.Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")).Copy , tempWorkbook.Worksheets(tempWorkbook.Worksheets.Count)  ' 将module中的宏绑定到按钮上 tempWorkbook.Worksheets("Sheet1").Shapes("Button 1").OnAction = tempWorkbook.Name & "!Module1.execute"  ' 保存文件 tempWorkbook.Save  ' 关闭文件 tempWorkbook.Close  writeLog objLogfile, "############## " & folderPath & fileName & "executed ##############" End If End If Next ' 递归 Set subFolders = basefolder.subFolders  For Each folder In subFolders  LoopAllSubFolders folder.path, template  NextEnd Sub' 判断Sheet是否存在Function worksheetExists(shtName, wb) Dim sht worksheetExists = False For Each sht In wb.Worksheets If sht.Name = shtName Then worksheetExists = True exit for End if NextEnd Function' 输出logSub writeLog(objLogfile, str)  objLogfile.WriteLine FormatDateTime(Now(), 1) & _  " " & FormatDateTime(Now(), 3) & " " & strEnd Sub' 判断文件是否存在Function IsExitAFile(filespec) Dim fso Set fso=CreateObject("Scripting.FileSystemObject")  If fso.fileExists(filespec) Then  IsExitAFile=True  Else IsExitAFile=False  End IfEnd Function' 删除文件Sub DeleteAFile(filespec) Dim fso Set fso= CreateObject("Scripting.FileSystemObject") fso.DeleteFile(filespec)End Sub