導讀之前的【工作拾遺2VBA工具實現Module和Sheet的拷貝及按鈕綁定宏】使用VBA實現的多文件相互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 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