|
……阿嚏……谁这么想我……呵~最近天气一天凉比一天，小伙伴们记得多穿几层秋裤……多喝温开水少熬夜……——以上是来自一位身穿短袖短裤大哥哥的贴心话。 咳~我们上期分享了：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) <> '\' 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 Cells.ClearContents Cells.NumberFormat = '@' '清空当前表数据并设置为文本格式 ' 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 '如果表中包含关键词则进行汇总(不区分关键词字母大小写） 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编程学习与实践 |
|
|
