返回目录：excel表格制作
1
昨天发过一种vba方法，把一个工作簿里上百个分表复制粘贴到当前工作簿的总表里，
只要几秒钟。
见这篇文章：
100个工作表，数据瞬间汇集到一个总表里，我只需要1秒！
今天给大家介绍另外一种绝招！神技！彪悍的人生无需解释！
假设你有几十个甚至几百个工作簿，每个工作簿里有若干表（少则一个，多则十几个工作表，每个表的数据结构相同，数据记录条数不等），现在你需要把这些工作簿里的每个工作表里的数据，复制粘贴到一个新工作簿的一个空白表里。
如果你有300个工作簿，每个工作簿里有7个工作表。假设这2000多个工作表里的数据记录（记录条数总数最多不能超过104万行，因为xlsx格式的单表最多行数是1048576行）都被复制粘贴到一个新工作簿里的某个空白表里，如果纯粹手工复制粘贴，操作熟练快速，中间不出任何差错，我毛估时间至少得10-15个小时。
也就是说你可能得机械地复制粘贴1-2个工作日的上班时间，中间不能有任何错误，否则可能意味着要检查甚至重新复制粘贴。
想必，有很多朋友这么干过。这么做过的人，都明白，枯躁乏味，苦不堪言，但却又无能为力！
2
下面是案例背景。
有300个工作簿，每个工作簿大概3-6个工作表不等，数据记录都是500行。
这些工作簿存储在某盘文件夹“多工作簿多表超级汇集”下的子文件夹“明细表”里
下面是其中一个工作簿里的一个工作表数据，记录数有500条。↓
而汇总表就存在“多工作簿多表超级汇集”这个文件夹下，见下图
3
打开工作簿“汇总表.xlsxm” (带VBA程序的excel工作簿应该保存为这种格式)
先学习第一种方法，在“总表”这个工作表里设置好表头，调整好列宽和格式，绘制好圆角矩形作为宏代码的执行按钮。
按ALT+F11，插入，模块，把以下代码复制到模块1里
Sub 汇总不带表名()
Dim wb, mypath, myfile, sh, zong
t = Timer '开始时间
Set zong = Sheets("总表")
zong.UsedRange.Offset(1, 0).ClearContents
mypath = ThisWorkbook.Path & "\\明细表\\"
myfile = Dir(mypath & "*.xlsx")
Do While myfile <> ""
Set wb = GetObject(mypath & myfile)
For Each sh In wb.Worksheets
On Error Resume Next
With sh
.UsedRange.Offset(1, 0).Copy zong.Cells(Range("a" & Rows.Count).End(xlUp).Row + 1, 1)
End With
Next
wb.Close False
myfile = Dir
Loop
Set wb = Nothing
MsgBox "数据合并用时：" & Format(Timer - t, "#0.000") & " 秒", , "则见温馨提示：汇总完成！每一天都是美妙的！"
End Sub
然后，关闭vba编辑窗口。右键单击按钮，指定宏，选择“汇总不带表名”，确定。
单击“提取”按钮，程序开始执行，大约6-7秒时间汇总完毕。时间长短取决于电脑内存以及汇总的工作表的数量（这里为了简化起见，只保留了7个工作簿，所以时间比较短，只有几秒钟）。
“总表”里的结果，是通过代码把各个表里的数据直接粘贴过来，没有考虑每个工作表的表名。
4
接下来再介绍一种vba写法，很多写法和上一种类似，就是加了增加表名作为列字段。
Sub 汇集带表名()
Dim wb, hui, mypath, myfile, sh, myirow, newirow
t = Timer '开始时间
Set hui = Sheets("汇集")
hui.UsedRange.Offset(1, 0).ClearContents
mypath = ThisWorkbook.Path & "\\明细表\\"
myfile = Dir(mypath & "*.xlsx")
Do While myfile <> ""
Set wb = GetObject(mypath & myfile)
For Each sh In wb.Worksheets
On Error Resume Next
With sh
myirow = hui.Range("B" & Rows.Count).End(xlUp).Row + 1
.UsedRange.Offset(1, 0).Copy hui.Cells(myirow, 2)
newirow = hui.Range("B" & Rows.Count).End(xlUp).Row
hui.Range("A" & myirow & ":A" & newirow) = sh.Name
End With
Next
wb.Close False
myfile = Dir
Loop
Set wb = Nothing
MsgBox "数据合并用时：" & Format(Timer - t, "#0.000") & " 秒", , "则见温馨提示：汇总完成！每一天都是美妙的！"
End Sub
其他细节略。
点击“超级汇”按钮，大概3分钟不到执行完毕。
执行时间总共160多秒。因为这里测试用到的要提取数据的工作簿个数是300个（工作表总数大概2000个）。
最后提取的记录数右789000行。
复制粘贴2000个工作表到一个总表里来，不过3分钟！
提醒下，是从300个工作簿里，复制粘贴到“汇集”表里的！
提醒下，“汇集”总表里，还增加一列城市字段，其实就是2000个工作表的表名！
如果全部靠人工来复制粘贴，那么15个小时-20个小时是跑不掉的！
而且做这个工作的人，简直痛不欲生，无语凝噎，估计双手都得抽筋！
但是，我们这段代码，只需要3分钟！
只需要180秒！
只需要180秒！
只需要180秒！
再不学习，还想又快又好，还想升职加薪，简直痴人说梦！
End.
来源：公众号“Excel和PPT职场见”
运行人员：中国统计网小编（微信号：itongjilove）
微博ID：中国统计网
中国统计网，是国内最早的大数据学习网站，公众号：中国统计网
http://www.itongji.cn