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