多个工作簿下多个工作表汇总代码求优化

nmghrt · 发表于 2019-1-22 13:01

本帖最后由 nmghrt 于 2019-1-22 14:46 编辑

首先非常感谢您能阅读我的帖子。我的工作是每月需要各分公司给我报一个Excel工作簿，每个工作簿中有数十个工作表。
当然，各分公司报来的工作簿中工作表格式、名称都是统一的，只是内容不同。
自打我接触VBA以来，就发现以前的复制粘贴简直是在浪费生命，像这种重复性的工作VBA肯定能解决，于是我各种百度，终于在网上找到了这样一段代码：

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

复制代码

但是这段代码在运行过程中，出了两个小问题：
1. 源表格数据量较大时提示我“运行错误‘7‘’：内存溢出”（附件中表格由于数据量较小，没出现这个问题）。
2. 这段代码是将所有工作簿内的所有工作表都汇总到一张表格上，有没有什么办法能让不同的工作簿下的工作表分别汇总呢？例如各工作簿下的sheet1都汇总到汇总表的sheet1中，sheet2都汇总到汇总表的sheet2中…以此类推。
注：各分公司报来的工作簿中各工作表顺序都是固定的，名称也是固定的。
请各位大神帮忙优化一下，或者有前辈有过此类教程，帮忙贴个链接，小弟在论坛内搜了好久，均没找到……
对您的帮助万分感谢！

cqcbc · 发表于 2019-1-22 20:58

本帖最后由 cqcbc 于 2019-1-22 21:13 编辑

运行一次宏，然后保存，出现提醒窗口：请输入需要合并的工作表所包含的关键词：输入如：Sheet1 (2)，这样只汇总Sheet1 (2)；更换输入的表名，再保存，直到结束。

乐乐2006201505 · 发表于 2019-1-22 21:15

试试这个，应该可以。
Sub tt()
Dim sht As Worksheet, p$, f$, d As Object, arr, brr, i&, j&, k&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
For Each sht In Worksheets
If sht.Name <> ActiveSheet.Name Then sht.Delete
Next
Set Sh = ActiveSheet
ReDim brr(1 To 200000, 1 To 20)
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls")
Do While f <> ""
If f <> ThisWorkbook.Name Then
      With GetObject(p & f)
         For Each sht In .Worksheets
            shtname = sht.Name
            arr = sht.[a1].CurrentRegion
            For i = 2 To UBound(arr)
                  k = k + 1
                  For j = 1 To UBound(arr, 2)
                     brr(k, j) = arr(i, j)
                  Next
                  brr(k, UBound(arr, 2) + 1) = Split(f, ".xls")(0)
                  If Not d.exists(shtname) Then
                     Set d(shtname) = CreateObject("scripting.dictionary")
                     For n = 1 To UBound(arr, 2)
                        s = s & "," & arr(1, n)
                     Next
                     d(shtname)(shtname) = Mid(s, 2)
                     s = ""
                  End If
                  d(shtname)(k) = ""
            Next
         Next
         .Close False
      End With
End If
f = Dir()
Loop
kr = d.keys
For i = 0 To UBound(kr)
With Worksheets.Add(, Sheets(Sheets.Count))
      .Name = kr(i)
      r = d(kr(i)).keys
      ReDim drr(1 To UBound(r) + 1, 1 To UBound(brr, 2))
      For x = 1 To UBound(r)
         For y = 1 To UBound(brr, 2)
            drr(x, y) = brr(r(x), y)
         Next
      Next
      ar = Split(d(kr(i))(kr(i)), ",")
      .[a1].Resize(1, UBound(ar) + 1) = ar
      .[a2].Resize(UBound(r) + 1, UBound(brr, 2)) = drr
End With
Next
Sh.Activate
Set d = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

cjc209 · 发表于 2019-1-22 21:18

Sub 多薄同名表重组为一薄多表()
Dim d As Object, p$, f$, h&, sh As Worksheet, nm$, n As Name
bm = ActiveSheet.Name
btzmh = Val(Application.InputBox("请输入标题最末行的行号：", "默认值", "1"))
bwh = Val(Application.InputBox("请输入表尾占据的总行数：", "默认值", "0"))
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Application.DisplayAlerts = False
Do While f <> ""
If f <> ThisWorkbook.Name Then
      With Workbooks.Open(p & f)
         For Each sh In .Worksheets
            nm = sh.Name
            If Not d.exists(nm) Then
                  d(nm) = ""
                  sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                  h2 = ThisWorkbook.Sheets(nm).UsedRange.Rows.Count + ThisWorkbook.Sheets(nm).UsedRange.Row - 1
                  If bwh > 0 Then
                  ThisWorkbook.Sheets(nm).Rows(h2 - bwh + 1 & ":" & h2).Delete
                  End If
            Else
                  With sh
                     h = sh.UsedRange.Rows.Count + sh.UsedRange.Row - 1 - btzmh - bwh
                     qsl = sh.UsedRange.Column
                     h1 = ThisWorkbook.Sheets(nm).UsedRange.Rows.Count + ThisWorkbook.Sheets(nm).UsedRange.Row
                     .UsedRange.Offset(btzmh).Resize(h).Copy ThisWorkbook.Sheets(nm).Cells(h1, qsl)
                  End With
            End If
         Next
         .Close 0
      End With
End If
f = Dir
Loop
On Error Resume Next
For Each n In ThisWorkbook.Names
n.Delete
Next
Err.Clear
Sheets(bm).Delete
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "提取完毕！"
End Sub

jjmysjg · 发表于 2019-1-22 21:39

留下记号。谢谢

chentonny · 发表于 2019-1-22 21:43

多簿多表的汇总例子坛里非常多。

blackttea1 · 发表于 2022-5-12 13:55

留下记号。谢谢

		自动登录	找回密码
密码			免费注册

[求助] 多个工作簿下多个工作表汇总代码求优化

最新热点 /1