求助：VBA多工作薄多工作表合并，保留表头

brother · 发表于 2014-12-21 20:03

本帖最后由 brother 于 2014-12-22 23:13 编辑

各位老师好：
1、总文件夹中又有若干个以省份命名的文件夹，每个省份下又有若干工作薄，每个工作薄中有6个表。
2、要将每个省份文件夹中的所有工作薄进行合并。合并到一个以此省份命名的工作薄中。并存放在总文件夹中。
3、每个工作薄中前两个表不参与合并，后4个表中数据进行合并，并保留表头。这4个表的表头分别为4、5、3、2行。
4、最后将各个省份中的所有工作薄合并为“全国汇总”的工作薄。请问如何用VBA实现此功能？详见附件，先行谢过！

liulang0808 · 发表于 2014-12-21 20:27

http://club.excelhome.net/thread-1165866-1-1.html
参考一下这个吧，看看是否能帮到你的

brother · 发表于 2014-12-21 23:42

liulang0808 发表于 2014-12-21 20:27
http://club.excelhome.net/thread-1165866-1-1.html
参考一下这个吧，看看是否能帮到你的

没看懂啊，我是个菜鸟，求各位老师能直接给个代码

brother · 发表于 2014-12-22 07:00

请哪位大师关注一下，帮帮菜鸟啊！急需要用，谢啦！

zhaogang1960 · 发表于 2014-12-22 08:12

请参考：

Sub Macro1()
Dim Fso As Object, Folder As Object
Dim i&, n&, a, b, wb As Workbook, wb2 As Workbook, p$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
a = Array(4, 5, 3, 2)
b = Array("基本情况（填表）", "老干部情况", "医务人员", "医疗设备")
For i = 1 To 4
Sheets(i).[a1].CurrentRegion.Offset(a(i - 1)).Clear
Next
Set Fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & "\各省汇总"
With ThisWorkbook
For Each SubFolder In Fso.GetFolder(p).SubFolders
n = 0
For Each File In SubFolder.Files
n = n + 1
Set wb = Workbooks.Open(File)
For i = 0 To 3
wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy .Sheets(b(i)).[a65536].End(xlUp).Offset(1)
Next
If n = 1 Then
wb.SaveAs p & "" & SubFolder.Name & "汇总表.xls"
Set wb2 = ActiveWorkbook
Else
For i = 0 To 3
wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy wb2.Sheets(b(i)).[a65536].End(xlUp).Offset(1)
Next
wb.Close False
End If
Next
wb2.Close True
Next
End With
Set Fso = Nothing
Application.ScreenUpdating = True
MsgBox "ok"
End Sub

复制代码

zhaogang1960 · 发表于 2014-12-22 08:14

请测试附件

全国汇总.rar (335.15 KB, 下载次数: 334)

brother · 发表于 2014-12-22 22:45

zhaogang1960 发表于 2014-12-22 08:14
请测试附件

太棒了，基本达到我要的结果，若是每个省份的汇总也不要汇总前两个表，即不要“打印封面(自动生成)”和“打印基本情况(自动生成)”，该如何改动代码？

zhaogang1960 · 发表于 2014-12-22 23:01

brother 发表于 2014-12-22 22:45
太棒了，基本达到我要的结果，若是每个省份的汇总也不要汇总前两个表，即不要“打印封面(自动生成)”和“ ...

Sub Macro1()
Dim Fso As Object, Folder As Object
Dim i&, n&, a, b, wb As Workbook, wb2 As Workbook, p$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
a = Array(4, 5, 3, 2)
b = Array("基本情况（填表）", "老干部情况", "医务人员", "医疗设备")
For i = 1 To 4
Sheets(i).[a1].CurrentRegion.Offset(a(i - 1)).Clear
Next
Set Fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & "\各省汇总"
With ThisWorkbook
For Each SubFolder In Fso.GetFolder(p).SubFolders
n = 0
For Each File In SubFolder.Files
n = n + 1
Set wb = Workbooks.Open(File)
For i = 0 To 3
wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy .Sheets(b(i)).[a65536].End(xlUp).Offset(1)
Next
If n = 1 Then
wb.Sheets(b).Copy
Set wb2 = ActiveWorkbook
Else
For i = 0 To 3
wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy wb2.Sheets(b(i)).[a65536].End(xlUp).Offset(1)
Next
End If
wb.Close False
Next
wb2.Close True, p & "" & SubFolder.Name & "汇总表.xls"
Next
End With
Set Fso = Nothing
Application.ScreenUpdating = True
MsgBox "ok"
End Sub

复制代码

zhaogang1960 · 发表于 2014-12-22 23:02

请测试附件

全国汇总.rar (335.01 KB, 下载次数: 288)

brother · 发表于 2014-12-22 23:10

zhaogang1960 发表于 2014-12-22 23:01

正是我想要的，非常非常棒！

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

[已解决] 求助：VBA多工作薄多工作表合并，保留表头

评分