合并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