VBA 合并同文件夹下多工作簿中同名工作表到 一工作簿一工作表

学习日志

批量合并excel工作簿中同名工作表，适用条件：
1、所有要汇总的工作簿在同一个文件夹中，这里以后缀为.xlsx为例；
2、需要合并的工作表名称相同（如： “sheet1”）,且数据字段一样（如：A列表示序号，B列表示姓名，C列表示月工资等,本例中指定数据位于a-c列）；
3、需要合并的数据所在区域起始行列一致（如：有相同的表头）

ALL IN ONE

Sub allinone()
    Dim path As String, filename As String
    Dim ws As Workbook, w As Workbook
    Dim starrow As Long, n As Long, r As Long, titlerow As Integer
    
    path = "C:\Users\Lee\Desktop\新建文件夹\全民一起VBA 提高篇\12"
    filename = Dir(path & "\*.xlsx")
    
    Set ws = Workbooks.Add
    '每次复制时开始的行数
    starrow = 1: n = 0: titlerow = 1
    Application.DisplayAlerts = False
    Do While filename <> ""
        Set w = Workbooks.Open(path & "\" & filename)
        n = n + 1
        '以下复制分表数据，第一张含表头，其他表格只复制数据区
        With w.Worksheets("sheet1")
            'xlCellTypeLastCell 可用11代替
            'Cells.SpecialCells(11).Row 包含字符的最后一个单元格所在行号
            
            r = Cells.SpecialCells(xlCellTypeLastCell).Row
            
            If n = 1 Then
                .Range("a1", "c" & r).Select
            Else
                .Range("a" & (titlerow + 1), "c" & r).Select
            End If
        End With
        Selection.Copy
        w.Close
        
        With ws.Worksheets("sheet1")
            .Range("b" & starrow).Select
            .Paste
            .Range("a" & starrow, "a" & (starrow + r - titlerow)) = Mid(filename, 1, Len(filename) - 5)
        End With
        
        '复制完后，根据B列中最后数据所在行号，重定义下次复制数据开始行号
        '.End(xlUp).Row指数据区域最后一行行号
        starrow = Range("b" & Rows.Count).End(xlUp).Row + 1
        
        filename = Dir
    Loop
    With ws.Worksheets("sheet1")
        .Range("a1", "a" & titlerow) = ""
        .Range("a" & Rows.Count).End(xlUp).value = ""
    End With
    
    Application.DisplayAlerts = True
    
    ws.SaveAs path & "\合并2.xlsx"
    
End Sub