VBA常用小代码203:汇总多个工作簿每个工作表名称包含指定关键词的数据到总表
……阿嚏……谁这么想我……呵~最近天气一天凉比一天，小伙伴们记得多穿几层秋裤……多喝温开水少熬夜……--以上是来自一位身穿短袖短裤大哥哥的贴心话。
咳~我们上期分享了:VBA常用小代码202:汇总指定文件夹下工作簿数据到总表
之后不断有朋友问，为什么这个代码只能汇总每个工作簿的第一张工作表啊，这是为什么啊?到底是为什么啊?
因为……抹泪……文章里有明确说明，它本来就是只汇总每个工作簿的第一张工作表啊。
……
……
好伐，打个响指，我们今天分享的内容是，汇总每个工作簿中工作表名称包含某个指定关键词的小代码。
举个栗子。假设有一文件夹，内有十几个工作簿，每个工作簿又各有多个不等数量的工作表，现在我们只想汇总每个工作簿中工作表名称包含“看见星光”的，那就可以使用我们今天分享的小代码了。
如果是想把所有工作表的数据一股脑全部汇总呢?不管它什么“看见星光”还是“看见月光”的--也可以使用今天的代码，程序运行中弹出的输入关键词对话框什么都不填直接确定就可以了。
小贴士:
1、(重复说明)如果需要汇总所有工作表的数据，关键词对话框什么都不填直接确定就可以了、另外关键词不区分字母大小写。
2、如果需要汇总的工作表含有多个不同的关键词……别急，由于代码汇总后的数据后增加一个“来源工作表”的字段，表亲们可以先把所有工作表的数据汇总，然后根据“来源工作表”字段对数据明细进行筛选删除操作。
动画操作:
代码如下:
Sub Collectwks()
'ExcelHome VBA编程学习与实践
Dim Sht As Worksheet, Rng As Range, Sh As Worksheet
Dim Trow&, k&, arr, brr, i&, j&, book&, a&
Dim p$, f$, Headr, Keystr
Application.ScreenUpdating = False'关闭屏幕更新
On Error Resume Next'忽略代码运行中可能出现的错误继续运行
'
With Application.FileDialog(msoFileDialogFolderPicker)
'取得用户选择的文件夹路径
.AllowMultiSelect = False
If .Show Then
p= .SelectedItems(1)
Else
Exit Sub
End If
End With
If Right(p, 1) <>>
'
Keystr = InputBox('请输入需要合并的工作表所包含的关键词:', '提醒')
If StrPtr(Keystr) = 0 Then Exit Sub
'如果点击了inputbox的取消或者关闭按钮，则退出程序
Trow = Val(InputBox('请输入标题的行数', '提醒'))
If Trow <>
Set Sht = ActiveSheet
Cells.ClearContents
Cells.NumberFormat = '@'
'清空当前表数据并设置为文本格式
'
f= Dir(p & '*.xls')'开始遍历工作簿
Do While f <>>
If f <>>'避免同名文件重复打开出错
With GetObject(p & f)
'以'只读'形式读取文件时，使用getobject方法会比workbooks.open稍快
For Each Sh In .Worksheets'遍历表
If InStr(1, Sh.Name, Keystr, vbTextCompare) Then
'如果表中包含关键词则进行汇总(不区分关键词字母大小写)
arr = .Sheets(1).UsedRange'数据区域读入数组arr
book = book + 1'标记一下是否首个Sheet
If book = 1 Then
ReDim brr(1 To 200000, 1 To UBound(arr, 2) + 1)
'如果是首个表格，则声明一个结果数组,20万行
Headr = Sh.[a1].Resize(Trow, UBound(arr, 2))
'将标题装入数组
a= Trow + 1'扣掉标题行后的数据区域的开始行
End If
For i = a To UBound(arr)'遍历行
k= k + 1'累加记录条数
brr(k, UBound(brr, 2)) = Sh.Name'结果数组brr的最后一列装入表名
For j = 1 To UBound(arr, 2)'遍历列
brr(k, j) = arr(i, j)
Next
Next
End If
Next
.Close False'关闭工作簿
End With
End If
f= Dir'下一个表格
Loop
If k > 0 Then
With Sht.[a1]
.Resize(Trow, UBound(Headr, 2)) = Headr'放标题
.Offset(Trow - 1, UBound(Headr, 2)) = '来源表名'
.Offset(Trow).Resize(k, UBound(brr, 2)) = brr'放数据区域
End With
MsgBox '汇总完成。'
End If
Application.ScreenUpdating = True'恢复屏幕更新
End Sub
………嗯~亲~记得穿秋裤……………
……记得穿秋裤………
~看见星光~唠叨而猝…
VBA编程学习与实践