合并excel全部的sheet的内容到单一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 0
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
 
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("»ã×Ü").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "»ã×Ü"
 
    StartRow = 3
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name = "Tools" Then
          GoTo NXFOR
        End If
        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
            If shLast > 0 And shLast >= StartRow Then
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "Too Row!"
                    GoTo ExitSub
                End If
                CopyRng.Copy
                DestSh.Cells(Last + 1, "A") = sh.Name
                With DestSh.Cells(Last + 2, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If
        End If
NXFOR:
    Next
ExitSub:
    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub