【Excel VBA 实战】一键批量合并多个工作表,自动汇总不重复

Sub 批量合并所有工作表并去重()    Dim ws As Worksheet, wsSum As Worksheet    Dim lastRow As Long, sumRow As Long    Dim colCount As Integer    Dim dic As Object    Set dic = CreateObject("Scripting.Dictionary")    '新建汇总表    On Error Resume Next    Application.DisplayAlerts = False    Sheets("汇总总表").Delete    Application.DisplayAlerts = True    On Error GoTo 0    Set wsSum = Sheets.Add(After:=Sheets(Sheets.Count))    wsSum.Name = "汇总总表"    sumRow = 1    '遍历所有工作表    For Each ws In Worksheets        If ws.Name <> "汇总总表" Then            If sumRow = 1 Then                '复制表头                ws.Rows(1).Copy wsSum.Rows(sumRow)                sumRow = sumRow + 1                colCount = ws.UsedRange.Columns.Count            End If            '复制数据行            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row            If lastRow >= 2 Then                ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, colCount)).Copy _                wsSum.Cells(sumRow, 1)                sumRow = sumRow + lastRow - 1            End If        End If    Next ws    '去重（以第1列为唯一标识）    With wsSum        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        For i = lastRow To 2 Step -1            keyStr = .Cells(i, 1).Value            If dic.Exists(keyStr) Then                .Rows(i).Delete            Else                dic.Add keyStr, i            End If        Next i    End With    '自动调整列宽    wsSum.UsedRange.EntireColumn.AutoFit    MsgBox "合并完成！" & Chr(13) & "共合并 " & Sheets.Count - 1 & " 个表" & Chr(13) & "去重后共 " & wsSum.Cells(Rows.Count, 1).End(xlUp).Row - 1 & " 条数据", vbOKOnly    Set dic = NothingEnd Sub