绝了，10秒完成批量汇总10W个工作薄指定某些工作簿的工作表到总表

绝了，10秒完成批量汇总10W个工作薄指定某些工作簿的工作表到总表：

需要汇总的源数据如下：

操作动画如下：

完成后的效果如下：

使用的代码如下所示：

Sub 合并多个工作薄Sheets() Dim P$, Bookn$, Book$, Keystr1, Keystr2, Shtname$, K& Dim Sht As Worksheet, Sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show Then P = .SelectedItems(1) Else: Exit Sub End With If Right(P, 1) <> '\' Then P = P & '\' Keystr1 = InputBox('请输入工作簿名称需要包含关键词。' & vbCr & '关键词如为空，如为空，则默认汇总全部工作簿') If StrPtr(Keystr1) = 0 Then Exit Sub '如果用户点击了取消或关闭按钮，则退出程序 Keystr2 = InputBox('请输入工作簿名称需要包含关键词。' & vbCr & '关键词如为空，如为空，则默认汇总全部工作簿') If StrPtr(Keystr2) = 0 Then Exit Sub Set Sh = ActiveSheet Bookn = Dir(P & '*.xls*') Do While Bookn <> '' If Bookn = ThisWorkbook.Name Then MsgBox '注意：指定文件夹中存在和当前表格重名的工作簿！！' & vbCr & '该工作簿无法打开，工作表无法复制。' Else If InStr(1, Bookn, Keystr1, vbTextCompare) Then With GetObject(P & Bookn) For Each Sht In .Worksheets If InStr(1, Sht.Name, Keystr2, vbTextCompare) Then If Application.CountIf(Sht.UsedRange, '<>') Then Shtname = Split(Bookn, '.xls')(0) & '-' & Sht.Name ThisWorkbook.Sheets(Shtname).Delete Sht.Copy after:=ThisWorkbook.Worksheets(Sheets.Count) K = K + 1 ActiveSheet.Name = Shtname End If End If Next .Close False End With End If End If Bookn = Dir Loop Sh.Select MsgBox '数据收集完毕，共合并：' & K & '个' Application.ScreenUpdating = True Application.DisplayAlerts = TrueEnd Sub

以上就是我与大家分享，我希望它能帮助你解决工作和学习中的一些问题。如果你觉得很好，就喜欢它。非常感谢您的关注。