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

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

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