VBA宏 合并EXCEL

1、合并多个Excel工作簿

Sub MergeWorkbooks()
    Dim FileSet
    Dim i As Integer
 
    On Error GoTo
    Application.ScreenUpdating = False
 
    FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", _
                                            MultiSelect:=True, Title:="选择要合并的文件")
 
    If TypeName(FileSet) = "Boolean" Then
        GoTo ExitSub
    End If
 
    For Each Filename In FileSet
        Workbooks.Open Filename
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Next
 
ExitSub:
    Application.ScreenUpdating = True
 
End Sub

2、合并一个工作簿下多个一致性SHEET

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo
End Function
 
Sub MergeSheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
 
    '新建“汇总”Sheet
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("汇总").Delete
    On Error GoTo
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "汇总"
 
    '开始复制的行号，无表头设置为1
    StartRow = 
 
    For Each sh In ActiveWorkbook.Worksheets
 
        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
 
            If shLast >  And shLast >= StartRow Then
 
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
 
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "超过最大容量！"
                    GoTo ExitSub
                End If
 
                CopyRng.Copy
                With DestSh.Cells(Last + , "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If
        End If
    Next
 
ExitSub:
    Application.GoTo DestSh.Cells()
    DestSh.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
 
End Sub