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

brothersonline

如附件所示：
1、每个目录内有多个工作薄。2、每个工作薄内工作表数目、工作表名称、格式相同。3、相同名称的工作表的表头所占行数一样
求：VBA程序
1、合并每个目录内的多个工作薄至一个工作薄。2、以目录名称命名合并后的工作薄。3、工作表名称仍然沿用。4、复制表头（每个工作表表头行数不一样，可提示用户输入每个表头所占行数，根据用户输入的数确定保留几行表头）。
不知道表达的是否清楚？坛子里的现有帖子都与我的需求不相符，求哪位大师给予帮助，不胜感激！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-19 07:31

………………

跳转到最佳答案楼层

brothersonline

自己顶一下，希望引起大神的注意。

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim mypath$$, wj$$, wb As Workbook
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. For i = Sheets.Count To 1 Step -1
   
7.     If Sheets(i).Name <> "汇总" Then Sheets(i).Delete
   
8. Next
   
9. mypath = ThisWorkbook.Path & "\河北省"
   
10. wj = Dir(mypath & "*.xls")
    
11. Do While wj <> ""
    
12.     Set wb = GetObject(mypath & wj)
    
13.     For i = 1 To wb.Sheets.Count
    
14.         zf = wb.Sheets(i).Name
    
15.         If Sheets(zf) Is Nothing Then
    
16.             With Sheets.Add(after:=Sheets(Sheets.Count))
    
17.                 wb.Sheets(i).UsedRange.Copy [a1]
    
18.                 ActiveSheet.Name = zf
    
19.             End With
    
20.         Else
    
21.             bth = Sheets(zf).[a:a].Find("编号", lookat:=xlWhole).Row
    
22.             h = Sheets(zf).Range("a65536").End(xlUp).Row + 1
    
23.             wb.Sheets(i).UsedRange.Offset(bth, 0).Copy Sheets(zf).Cells(h, 1)
    
24.         End If
    
25.     Next
    
26.     wb.Close 0
    
27.     wj = Dir
    
28. Loop
    
29. Sheets("汇总").Activate
    
30. Application.DisplayAlerts = True
    
31. Application.ScreenUpdating = True
    
32. End Sub

复制代码

dsmch

………………

dyzx

dsmch 发表于 2014-12-19 07:31
………………

dsmch老师：这个程序非常好，多谢老师辛勤付出，多谢

brothersonline

dsmch 发表于 2014-12-19 07:30

感谢dsmch老师，这个问题确实解决了，不过还有问题还要请教一下：
1、我的目录下还有很多省份目录，如何让各省份目录下的工作薄自动汇总到以目录命名的工作薄中？
2、以下代码：

•         If Sheets(zf) Is Nothing Then
•             With Sheets.Add(after:=Sheets(Sheets.Count))
•                 wb.Sheets(i).UsedRange.Copy [a1]
•                 ActiveSheet.Name = zf
•             End With
•         Else
•             bth = Sheets(zf).[a:a].Find("编号", lookat:=xlWhole).Row
•             h = Sheets(zf).Range("a65536").End(xlUp).Row + 1
•             wb.Sheets(i).UsedRange.Offset(bth, 0).Copy Sheets(zf).Cells(h, 1)
•         End If
•     Next
•     wb.Close 0
•     wj = Dir
• Loop
  

能请dsmch老师给个注释吗？

3、请问程序是如何判断表头的？是查找“编号”所在行以上的部分为表头吗？如果每个表中的表头不一定是以“编号”开头的呢？

请dsmch老师不吝赐教！

brothersonline

dsmch 发表于 2014-12-19 07:31
………………

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

brothersonline

dsmch 发表于 2014-12-19 07:31
………………

已开新帖，请老师不吝赐教！http://www.excelpx.com/thread-336339-1-1.html

brothersonline

按照dsmch老师的要求，给出了模拟结果，附件在7楼更新。

brothersonline

已经有大量帮助解决问题，发上来供大家参考:
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