另类汇总工作簿

cxloen

感谢网友的帮助，终于调试成功如下代码，分享给各位
1 选择需要汇总的工作簿路径；
2 将所有工作簿按工作表名汇总在一个工作簿上；

欢迎各位大大优化代码提高程序执行速度
欢迎各位在此基础上增加功能，谢谢



Sub hzworkbook()
    '定义工作簿路径
     Dim Filename$, myPath$                '文件名，路径
    Dim thesh As Object
    Dim thefolder As Object
    Dim hzbook As String    '定义汇总工作簿
    hzbook = ActiveWorkbook.Name
    Dim n   '定义表头行数
    Dim i, j  '定义打开工作簿sheet数
    n = 1
    Set thesh = CreateObject("shell.application")
    Set thefolder = thesh.BrowseForFolder(0, "", 0, "")
       myPath = thefolder.Items.Item.Path
        myPath = myPath & Application.PathSeparator
      
       n = InputBox("请输入表头行数", 0, 1)
       n = n + 1
   
       Application.ScreenUpdating = False
    For Each ST In Sheets
        ST.UsedRange.Offset(1, 0).ClearContents
    Next
   
   
   
   
    myfile = Dir(myPath & "\*.xls")
    Do Until myfile = ""
   
        If myfile <> hzbook Then
            Set fs = Workbooks.Open(myPath & "\" & myfile)
            j = Sheets.Count
            MsgBox ("sheets" & i)
            For i = 1 To j
                With fs.Sheets(i)
                    Dim stname As String
                    stname = fs.Sheets(i).Name
                     .Range("A" & n & ":Z" & Range("A65536").End(xlUp).Row).Copy Workbooks(hzbook).Sheets(stname).Range("A65536").End(xlUp)(2)    'Z为中最后列
                End With
            Next
            fs.Close
        End If
        myfile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

linshuyan

学习

thzss

下载测试一下,谢谢提供