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

brother

zhaogang1960 发表于 2014-12-22 23:02
请测试附件

赵老师，非常感谢您的解答，可否以窗体的形式，获取某一文件夹的路径，然后合并此文件夹下的工作薄呢？请赐教！
北京地区数据汇总.rar (102.04 KB, 下载次数: 21)

2014-12-28 15:05 上传

点击文件名下载附件

zhaogang1960

1. Sub Macro1()
   
2.     Dim Fso As Object, Folder As Object
   
3.     Dim i&, n&, a, b, wb As Workbook, wb2 As Workbook, p$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         p = .SelectedItems(1)
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.     a = Array(4, 5, 3, 2)
    
12.     b = Array("基本情况（填表）", "老干部情况", "医务人员", "医疗设备")
    
13.     For i = 1 To 4
    
14.         Sheets(i).[a1].CurrentRegion.Offset(a(i - 1)).Clear
    
15.     Next
    
16.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
17.     With ThisWorkbook
    
18.         For Each SubFolder In Fso.GetFolder(p).SubFolders
    
19.             n = 0
    
20.             For Each File In SubFolder.Files
    
21.                 n = n + 1
    
22.                 Set wb = Workbooks.Open(File)
    
23.                 For i = 0 To 3
    
24.                     wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy .Sheets(b(i)).[a65536].End(xlUp).Offset(1)
    
25.                 Next
    
26.                 If n = 1 Then
    
27.                     wb.Sheets(b).Copy
    
28.                     Set wb2 = ActiveWorkbook
    
29.                 Else
    
30.                     For i = 0 To 3
    
31.                         wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy wb2.Sheets(b(i)).[a65536].End(xlUp).Offset(1)
    
32.                     Next
    
33.                 End If
    
34.                 wb.Close False
    
35.             Next
    
36.             wb2.Close True, p & "" & SubFolder.Name & "汇总表.xls"
    
37.         Next
    
38.     End With
    
39.     Set Fso = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "ok"
    
42. End Sub
    

复制代码

zhaogang1960

11楼附件仅是原来的一部分，下面附件还是原来的，只能指定存放各省文件夹的总文件夹
全国汇总.rar (333.44 KB, 下载次数: 88)

2014-12-28 18:46 上传

点击文件名下载附件

brother

zhaogang1960 发表于 2014-12-28 18:46
11楼附件仅是原来的一部分，下面附件还是原来的，只能指定存放各省文件夹的总文件夹

zhaogang1960老师您好，可能是我没说明白，现在的要求是只汇总一个目录下的所有工作薄，不再有多级目录。具体要求：点击“汇总”按钮后，提示查找工作薄所在目录，将所在目录下的工作薄数据汇总到当前的工作薄中，例如：“北京”目录下有7个工作薄，点击当前工作薄的“汇总”按钮，将目录下的7个工作薄数据汇总至当前工作薄。因要求没说明白，给您添麻烦了，非常感谢您!

brother

zhaogang1960 发表于 2014-12-28 18:44

zhaogang1960老师您好：如果工作薄中有5个表，是不是代码要改成：

• Sub Macro1()
•     Dim Fso As Object, Folder As Object
•     Dim i&, n&, a, b, wb As Workbook, wb2 As Workbook, p$
•     With Application.FileDialog(msoFileDialogFolderPicker)
•         .InitialFileName = ThisWorkbook.Path & "\"
•         If .Show = False Then Exit Sub
•         p = .SelectedItems(1)
•     End With
•     Application.ScreenUpdating = False
•     Application.DisplayAlerts = False
•     a = Array(4, 5, 5, 3, 2)
•     b = Array("基本情况（填表）", "老干部情况", "遗属情况", "医务人员", "医疗设备")
•     For i = 1 To 5
•         Sheets(i).[a1].CurrentRegion.Offset(a(i - 1)).Clear
•     Next
•     Set Fso = CreateObject("Scripting.FileSystemObject")
•     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 4
•                     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 4
•                         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
  

brother

zhaogang1960 发表于 2014-12-28 18:46
11楼附件仅是原来的一部分，下面附件还是原来的，只能指定存放各省文件夹的总文件夹

zhaogang1960老师您好，可能是我没说明白，现在的要求是只汇总一个目录下的所有工作薄，不再有多级目录。具体要求：点击“汇总”按钮后，提示查找工作薄所在目录，将所在目录下的工作薄数据汇总到当前的工作薄中，例如：“北京”目录下有7个工作薄，点击当前工作薄的“汇总”按钮，将目录下的7个工作薄数据汇总至当前工作薄。因要求没说明白，给您添麻烦了，非常感谢您!

zhaogang1960

brother 发表于 2014-12-28 20:38
zhaogang1960老师您好，可能是我没说明白，现在的要求是只汇总一个目录下的所有工作薄，不再有多级目录。 ...

1. Sub Macro1()
   
2.     Dim Fso As Object, Folder As Object
   
3.     Dim i&, n&, a, b, wb As Workbook, p$
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         .InitialFileName = ThisWorkbook.Path & ""
   
6.         If .Show = False Then Exit Sub
   
7.         p = .SelectedItems(1)
   
8.     End With
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.     a = Array(4, 5, 3, 2)
    
12.     b = Array("基本情况（填表）", "老干部情况", "医务人员", "医疗设备")
    
13.     For i = 1 To 4
    
14.         Sheets(i).[a1].CurrentRegion.Offset(a(i - 1)).Clear
    
15.     Next
    
16.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
17.     With ThisWorkbook
    
18.         For Each File In Fso.GetFolder(p).Files
    
19.             If File.Name Like "*.xls" Then
    
20.                 n = n + 1
    
21.                 Set wb = Workbooks.Open(File)
    
22.                 For i = 0 To 3
    
23.                     wb.Sheets(b(i)).[a1].CurrentRegion.Offset(a(i)).Copy .Sheets(b(i)).[a65536].End(xlUp).Offset(1)
    
24.                 Next
    
25.                 wb.Close False
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Set Fso = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "ok"
    
32. End Sub
    

复制代码

zhaogang1960

请测试附件

北京地区数据汇总.rar (96.92 KB, 下载次数: 168)

2014-12-28 21:20 上传

点击文件名下载附件

brother

zhaogang1960 发表于 2014-12-28 21:21
请测试附件

非常感谢，正是，正是!

hahbin

请问赵老师，要是原来的表最下边有填表说明，該怎么把填表说明去掉了