【VBA代码】-汇总同一文件夹下相同表头的工作簿

Option Explicit

Public Sub 汇总工作簿()
    Dim  r As Long, c As Long
    r = 1 '表头行数
    c = 8 '表头列数
    Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清除汇总表里的原始数据
    Application.ScreenUpdating = False
    Dim filename As String, wb As Workbook, erow As Long, fn As String, arr As Variant, sht As Worksheet
    filename = Dir(ThisWorkbook.Path & "\*.xls") '指定文件夹（即此工作簿所在的文件夹）中的第一个Excel文件名称
    Do While filename <> ""
        If filename <> ThisWorkbook.Name Then
            erow = Range("A1").CurrentRegion.Rows.Count + 1 '取得汇总表内第一个空行行号
            fn = ThisWorkbook.Path & "\" & filename '此时的文件所在路径
            Set wb = GetObject(fn) '激活fn所表示工作簿的对象
            Set sht = wb.Worksheets(1)
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "A").End(xlUp).Offset(0, c - 1)) '将数据区域中的记录保存到数组arr中
            Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr '将数组的值写入到汇总表中
            wb.Close False '关闭活动工作簿
        End If
        filename = Dir '取下一个文件名
    Loop
    With Range("A1").CurrentRegion.Font '汇总完成后，批量设置工作表的字体格式
        .Name = "微软雅黑"
        .Size = 12
        .Color = RGB(0, 0, 0)
    End With
    Application.ScreenUpdating = True
End Sub

笔记：Ubound(arr,1）得到数组arr的最大行数；Ubound（arr,2）得到数组arr的最大列数