Sub CollectIt()
Dim oWsTo As Excel.Worksheet, WsCnt As Long, rngLst As Range, rngTo As Range
WsCnt = Sheets.Count
Set oWsTo = Sheets.Add(After:=Sheets(WsCnt))
For WsCnt = 1 To WsCnt
With oWsTo
With .UsedRange
Set rngTo = .Cells(.Cells.Count)
End With
Set rngTo = .Cells(rngTo.Row, 1).Offset(2)
With Sheets(WsCnt)
rngTo.Value = .Name
With .UsedRange
Set rngLst = .Cells(.Cells.Count)
End With
.Range(.Cells(1), rngLst).Copy
rngTo.Offset(1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone
End With
End With
Next WsCnt
oWsTo.Range(Rows(1), Rows(2)).Delete
End Sub