请教，多个工作簿的制定表格合并到新建工作簿

e别来无恙

如附件中，每家机构都有BB01、BB02、BB03等表（为了便于举例我只设定了三张表格，且数据格式基本相同，实际使用时同一机构不同报表的格式是不同的，不同机构同一报表的数据内容是不同的），每家机构的同一报表格式相同数据不同，用VBA程序是否能够实现将每家机构的同一报表合并在一个工作簿中，工作簿中工作表的名字为第五位到第八位的代码。
换一个描述
将GFAB4301-2016007到GFAB4335-2016007（各机构报表）以及GFHZ0043-2016007（各机构汇总报表）中的BB01表合并为工作簿BB01，BB01中的工作表数据为各机构的BB01表，表名为4301-4335以及0043
将GFAB4301-2016007到GFAB4335-2016007（各机构报表）以及GFHZ0043-2016007（各机构汇总报表）中的BB01表合并为工作簿BB02，BB01中的工作表数据为各机构的BB02表，表名为4301-4335以及0043
将GFAB4301-2016007到GFAB4335-2016007（各机构报表）以及GFHZ0043-2016007（各机构汇总报表）中的BB01表合并为工作簿BB03，BB01中的工作表数据为各机构的BB03表，表名为4301-4335以及0043
以此类推，GFAB、GFHZ表为基础表，BB01、BB02、BB03为要实现的结果
我只会用比较笨拙的办法就是设定好BB01工作簿，然后每张工作簿引用相应工作表的数据
请论坛里的大师帮忙做个小程序，描述不准确的地方请包涵，非常感谢您的帮忙！

opiona

1. Sub Opiona()
   
2. 
   
3. '禁止系统刷屏?触发其他事件等
   
4. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
5. Application.ScreenUpdating = False '//关闭屏幕刷新
   
6. Application.DisplayAlerts = False '//关闭系统提示
   
7. Application.EnableEvents = False  '//禁止触发其他事件
   
8. t = Timer   '//开始时间
   
9. 
   
10.     Path原始 = ThisWorkbook.Path & "\原始数据"
    
11.     Path结果 = ThisWorkbook.Path & "\结果"
    
12.    
    
13.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
14.     If FSO.FolderExists(Path结果) = True Then
    
15.         FSO.GetFolder(Path结果).Delete   '//删除文件夹
    
16.     Else
    
17.         
    
18.     End If
    
19.    
    
20.     FileArr = FileAllArr(Path原始, "*.xls?", ThisWorkbook.Name, True, False)
    
21.     MkDir Path结果    '//创建文件夹
    
22.    
    
23.     For I = 0 To UBound(FileArr)
    
24.         Set WB = Workbooks.Open(FileArr(I))   '//打开原始数据的每个文件
    
25.         
    
26.         For Each SHW In WB.Worksheets   '//遍历所有工作表
    
27.         
    
28.             PATH当前 = Path结果 & "" & SHW.Name & ".XLSX"   '//保存到哪个工作簿
    
29.             If InStr(Str工作表名, "|" & SHW.Name & "|") = 0 Then  '//没有就创建此工作簿
    
30.                 Str工作表名 = Str工作表名 & SHW.Name & "|"
    
31.                 Set WBX = Workbooks.Add
    
32.                 WBX.SaveAs Filename:=PATH当前
    
33.                 WBX.Close True
    
34.             End If
    
35.             
    
36.             Rem 打开已经创建的表
    
37.             Set WBX = Workbooks.Open(PATH当前)
    
38.             Rem 创建新的工作表
    
39.             WBX.Worksheets.Add(Before:=WBX.Worksheets(1)).Name = Mid(GetPathFromFileName(FileArr(I)), 5, 4)
    
40.             Set SHX = WBX.Worksheets(Mid(GetPathFromFileName(FileArr(I)), 5, 4))
    
41.             SHW.Cells.Copy SHX.Range("A1")
    
42.             WBX.Close True
    
43.         Next SHW
    
44.         
    
45.         WB.Close True  '//保存
    
46.     Next I
    
47. 
    
48. Application.EnableEvents = True  '//  '//恢复触发其他事件
    
49. Application.ScreenUpdating = True '//恢复屏幕刷新
    
50. Application.DisplayAlerts = True '//恢复系统提示
    
51. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
52. End Sub

复制代码

opiona

可能要几分钟等待

2016年7月报表.rar (258.54 KB, 下载次数: 34)

2016-8-16 14:42 上传

点击文件名下载附件

e别来无恙

opiona 发表于 2016-8-16 14:42
可能要几分钟等待

非常感谢，我试试看

e别来无恙

e别来无恙 发表于 2016-8-16 16:24
非常感谢，我试试看

已经试过了，可以使用，太感谢了，如果只想针对几个工作簿中的其中一个工作表进行拆分合并，是否可以在汇总表中增加一个表名的输入，只针对特定工作表拆分合并？

e别来无恙

opiona 发表于 2016-8-16 14:42
可能要几分钟等待

已经试过了，可以使用，太感谢了，如果只想针对几个工作簿中的其中一个或几个工作表进行拆分合并，是否可以在汇总表中增加一个表名的输入，只针对特定工作表拆分合并？

opiona

1. 
   
2. Sub Opiona()
   
3. 
   
4. '禁止系统刷屏?触发其他事件等
   
5. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
6. Application.ScreenUpdating = False '//关闭屏幕刷新
   
7. Application.DisplayAlerts = False '//关闭系统提示
   
8. Application.EnableEvents = False  '//禁止触发其他事件
   
9. t = Timer   '//开始时间
   
10. 
    
11.     Set SH1 = Worksheets("Sheet1")
    
12.    
    
13.     Rem ARX工作表名 = Split("BB01,BB02,BB03", ",")  '//指定：工作表
    
14.     ARX工作表名 = SH1.Range("A2:A" & SH1.Range("A20").End(3).Row).Value  '//指定：工作表,此处最多19个，可以改
    
15. 
    
16.     If SH1.Range("A20").End(3).Row = 2 Then   '//处理仅有一个的情况
    
17.         ReDim ARX(1 To 1)
    
18.         ARX(1) = ARX工作表名
    
19.     Else
    
20.         ReDim ARX(1 To UBound(ARX工作表名, 1))
    
21.         For X = 1 To UBound(ARX工作表名, 1)
    
22.             ARX(X) = ARX工作表名(X, 1)
    
23.         Next X
    
24.     End If
    
25.    
    
26.     Path原始 = ThisWorkbook.Path & "\原始数据"
    
27.     Path结果 = ThisWorkbook.Path & "\结果"
    
28.    
    
29.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
30.     If FSO.FolderExists(Path结果) = True Then
    
31.         FSO.GetFolder(Path结果).Delete   '//删除文件夹
    
32.     End If
    
33.    
    
34.     FileArr = FileAllArr(Path原始, "*.xls?", ThisWorkbook.Name, True, False)
    
35.     MkDir Path结果    '//创建文件夹
    
36.    
    
37.    
    
38.     For I = 0 To UBound(FileArr)
    
39.         Set WB = Workbooks.Open(FileArr(I))  '//打开原始数据的每个文件
    
40.         
    
41.         For X = 1 To UBound(ARX) '//遍历所有指定：工作表
    
42.         
    
43.             Set SHW = WB.Worksheets(ARX(X))
    
44.             
    
45.             PATH当前 = Path结果 & "" & SHW.Name & ".XLSX"   '//保存到哪个工作簿
    
46.             If FSO.FileExists(PATH当前) = False Then   '//没有就创建此工作簿
    
47.                 Set WBX = Workbooks.Add
    
48.                 WBX.SaveAs Filename:=PATH当前
    
49.                 WBX.Close True
    
50.             End If
    
51. 
    
52.             Rem 打开已经创建的表
    
53.             Set WBX = Workbooks.Open(PATH当前)
    
54.             Rem 创建新的工作表
    
55.             WBX.Worksheets.Add(Before:=WBX.Worksheets(1)).Name = Mid(GetPathFromFileName(FileArr(I)), 5, 4)
    
56.             Set SHX = WBX.Worksheets(Mid(GetPathFromFileName(FileArr(I)), 5, 4))
    
57.             SHW.Cells.Copy SHX.Range("A1")
    
58.             WBX.Close True
    
59.             
    
60.         Next X
    
61.         
    
62.         WB.Close True  '//保存
    
63.     Next I
    
64. 
    
65. Application.EnableEvents = True  '//  '//恢复触发其他事件
    
66. Application.ScreenUpdating = True '//恢复屏幕刷新
    
67. Application.DisplayAlerts = True '//恢复系统提示
    
68. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
69. End Sub

复制代码

opiona

2016年7月报表.rar (206.32 KB, 下载次数: 23)

2016-8-17 08:14 上传

点击文件名下载附件

lsc900707

你想汇总哪个表，就在代码里修改一下好了。

e别来无恙

opiona 发表于 2016-8-17 08:24

非常感谢，完美解决了！