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