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秒!
再不学习,还想又快又好,还想升职加薪,简直痴人说梦!