excel自动获取vbscript数据（使用VBScript实现多Excel文件相互sheet拷贝等操作）

之前的【工作拾遗2 VBA工具实现Module和Sheet的拷贝及按钮绑定宏】使用VBA实现的多文件相互sheet拷贝在实践中，发现文件的数量越多，文件的大小越大，VBA工具越不稳定经常会出现各种奇怪的问题出现问题的时候， 就需要手工干预这主要是因为VBA不够稳定，而且非常耗费内存更改为VBScript后，性能问题大为改善 基本不需要人工干预了，今天小编就来聊一聊关于excel自动获取vbscript数据?接下来我们就一起去研究一下吧!

excel自动获取vbscript数据

之前的【工作拾遗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 Next End 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 Next End Function ' 输出log Sub writeLog(objLogfile, str) objLogfile.WriteLine FormatDateTime(Now(), 1) & _ " " & FormatDateTime(Now(), 3) & " " & str End Sub ' 判断文件是否存在 Function IsExitAFile(filespec) Dim fso Set fso=CreateObject("Scripting.FileSystemObject") If fso.fileExists(filespec) Then IsExitAFile=True Else IsExitAFile=False End If End Function ' 删除文件 Sub DeleteAFile(filespec) Dim fso Set fso= CreateObject("Scripting.FileSystemObject") fso.DeleteFile(filespec) End Sub