Excel VBA 将不同工作簿中的工作表，按照工作表名里相同的关键词汇总

命令从下面第一个Sub开始：

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