用 VBA 合并多个 Excel 表:不同表头、不同顺序,也能一键拼成一张总表

Sub 合并同结构工作簿() Dim fPath As String, fName As String Dim wbS As Workbook, wsS As Worksheet Dim arr As Variant Dim nextRow As Long Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual fPath = "C:\Reports\Incoming\" ' 末尾反斜杠不能省 fName = Dir(fPath & "*.xlsx") nextRow = 1 Do While fName <> "" Set wbS = Workbooks.Open(fPath & fName, ReadOnly:=True, UpdateLinks:=0) Set wsS = wbS.Worksheets(1) arr = wsS.UsedRange.Value ' 一次性读入数组（含表头） If nextRow = 1 Then Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr nextRow = UBound(arr, 1) + 1 Else ' 跳过表头，只写数据 Cells(nextRow, 1).Resize(UBound(arr, 1) - 1, UBound(arr, 2)).Value = _ wsS.Range("A2").Resize(UBound(arr, 1) - 1, UBound(arr, 2)).Value nextRow = nextRow + UBound(arr, 1) - 1 End If wbS.Close SaveChanges:=False fName = Dir Loop Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "合并完成！共写入 " & nextRow - 1 & " 行。", vbInformation End Sub

Sub 合并异结构工作簿() Dim wbS As Workbook, wsS As Worksheet Dim dict As Object, srcDict As Object Dim headers, srcData As Variant Dim fPath As String, fName As String Dim lastRowSrc As Long, lastColSrc As Long, i As Long, j As Long, k As Long Dim outBuf As Variant, bufRow As Long, nextRow As Long Set dict = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Application.DisplayAlerts = False ' 1) 标准表头与列顺序 headers = Array("日期", "部门", "客户", "金额", "备注") For k = 0 To UBound(headers) Cells(1, k + 1).Value = headers(k) dict(headers(k)) = k + 1 Next k ' 2) 遍历每个文件 fPath = "C:\Reports\Incoming\" fName = Dir(fPath & "*.xlsx") Do While fName <> "" Set wbS = Workbooks.Open(fPath & fName, ReadOnly:=True, UpdateLinks:=0) Set wsS = wbS.Worksheets(1) lastRowSrc = wsS.Cells(wsS.Rows.Count, 1).End(xlUp).Row lastColSrc = wsS.Cells(1, wsS.Columns.Count).End(xlToLeft).Column srcData = wsS.Range(wsS.Cells(1, 1), wsS.Cells(lastRowSrc, lastColSrc)).Value ' 3) 建立"源表头 -> 源列号"映射 Set srcDict = CreateObject("Scripting.Dictionary") For j = 1 To lastColSrc srcDict(CStr(srcData(1, j))) = j Next j ' 4) 内存里按标准表头对齐，最后一列记来源文件名 If lastRowSrc > 1 Then ReDim outBuf(1 To lastRowSrc - 1, 1 To UBound(headers) + 1) bufRow = 0 For i = 2 To lastRowSrc bufRow = bufRow + 1 For k = 0 To UBound(headers) If srcDict.Exists(headers(k)) Then outBuf(bufRow, dict(headers(k))) = srcData(i, srcDict(headers(k))) End If Next k outBuf(bufRow, UBound(headers) + 1) = fName Next i nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 Cells(nextRow, 1).Resize(lastRowSrc - 1, UBound(headers) + 1).Value = outBuf End If wbS.Close SaveChanges:=False fName = Dir Loop Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "合并完成！", vbInformation End Sub