今天再分享下匯總指定文件夾下每個工作簿中工作表名稱包含某個指定關鍵詞的小代碼（當不指定關鍵詞時，則默認匯總所有工作表數據）。
舉個慄子。假設有一文件夾，內有十幾個工作簿，每個工作簿又各有多個不等數量的工作表，現在我們只想匯總每個工作簿中工作表名稱包含「看見星光」的數據，那就可以使用我們今天分享的小代碼了。
如果是想把所有工作表的數據一股腦全部匯總呢？不管它什麼「看見星光」還是「看見月光」的——也可以使用今天的代碼，程序運行中彈出的輸入關鍵詞對話框什麼都不填直接確定就可以了。
小貼士：
1、（重複說明）如果需要匯總所有工作表的數據，關鍵詞對話框什麼都不填直接確定就可以了、另外關鍵詞不區分字母大小寫。
2、如果需要匯總的工作表含有多個不同的關鍵詞……也是可以的，由於代碼匯總後的數據後增加一個「來源工作表」的欄位，表親們可以先把所有工作表的數據匯總，然後根據「來源工作表」欄位對數據明細進行篩選刪除操作。
代碼如下：
Sub Collectwks()
Dim Sht As Worksheet, rng As Range, Sh As Worksheet
Dim Trow&, k&, arr, brr, i&, j&, book&, a&
Dim p$, f$, Headr, Keystr
'
With Application.FileDialog(msoFileDialogFolderPicker)
'取得用戶選擇的文件夾路徑
.AllowMultiSelect = False
If .Show Then p = .SelectedItems(1) Else Exit Sub
End With
If Right(p, 1) <> "\" Then p = p & "\"
'
Keystr = InputBox("請輸入需要合併的工作表所包含的關鍵詞：", "提醒")
If StrPtr(Keystr) = 0 Then Exit Sub
'如果點擊了inputbox的取消或者關閉按鈕，則退出程序
Trow = Val(InputBox("請輸入標題的行數", "提醒"))
If Trow < 0 Then MsgBox "標題行數不能為負數。", 64, "警告": Exit Sub
Set Sht = ActiveSheet
Application.ScreenUpdating = False '關閉屏幕更新
Cells.ClearContents
Cells.NumberFormat = "@"
'清空當前表數據並設置為文本格式
ReDim brr(1 To 200000, 1 To 2)
'定義裝匯總結果的數組brr，最大行數為20萬行，2列是臨時的
'
f = Dir(p & "*.xls*") '開始遍歷工作簿
Do While f <> ""
If f <> ThisWorkbook.Name Then '避免同名文件重複打開出錯
With GetObject(p & f)
'以'只讀'形式讀取文件時，使用getobject方法會比workbooks.open稍快
For Each Sh In .Worksheets '遍歷表
If InStr(1, Sh.Name, Keystr, vbTextCompare) Then
'如果表中包含關鍵詞則進行匯總(不區分關鍵詞字母大小寫）
Set rng = Sh.UsedRange
If rng.Count > 1 Then
'如果rng的單元格數量大於1……
book = book + 1 '標記一下是否首個Sheet,如果首個sheet，BOOK=1
a = IIf(book = 1, 1, Trow + 1) '遍歷讀取arr數組時是否扣掉標題行
arr = rng.Value '數據區域讀入數組arr
If UBound(arr, 2) + 2 > UBound(brr, 2) Then
'動態調整結果數組brr的最大列數，避免明細表列數不一的情況。
ReDim Preserve brr(1 To 200000, 1 To UBound(arr, 2) + 2)
End If
For i = a To UBound(arr) '遍歷行
k = k + 1 '累加記錄條數
brr(k, 1) = f '數組第一列放工作簿名稱
brr(k, 2) = Sh.Name '數組第二列放工作表名稱
For j = 1 To UBound(arr, 2) '遍歷列
brr(k, j + 2) = arr(i, j)
Next
Next
End If
End If
Next
.Close False '關閉工作簿
End With
End If
f = Dir '下一個表格
Loop
If k > 0 Then
Sht.Select
[a1].Offset(IIf(Trow = 0, 1, 0)).Resize(k, UBound(brr, 2)) = brr '放數據區域
[a1].Resize(1, 2) = [{"來源工作簿名稱","來源工作表名"}]
MsgBox "匯總完成。"
End If
Application.ScreenUpdating = True '恢復屏幕更新
End Sub