vba combime all sheets in a workbook

[lyambor]

I thought this vba routine combined all sheets in workbook into a sheet labeled combined
It also included a column with name of sheet so I can pivot which is very helpful

but I have a workbook of over 128 sheets and the routine does not seem to catch all of the sheets

anyone see what the issue is?
or has a routine that works for all sheets - any number of sheets in a workbook -any number of rows (columns all the same)

thank you

Sub combined()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate

ActiveSheet.Range("A1").EntireColumn.Insert
ActiveSheet.Range("A1:A" & Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row).Value = ActiveSheet.Name

Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")

ActiveSheet.Columns("A").EntireColumn.Delete

For J = 2 To Sheets.Count
Sheets(J).Activate

ActiveSheet.Range("A1").EntireColumn.Insert
ActiveSheet.Range("A1:A" & Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row).Value = ActiveSheet.Name

Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)

ActiveSheet.Columns("A").EntireColumn.Delete

Next
End Sub

 

[mumps]

Try:

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWs As Worksheet, bottomA As Long, LastRow As Long
    Worksheets.Add.Name = "Combined"
    Set desWs = Sheets("Combined")
    Sheets(2).Rows(1).EntireRow.Copy desWs.Cells(1, 1)
    desWs.Range("A1").EntireColumn.Insert
    desWs.Cells(1, 1) = "Sheet Name"
    For Each ws In Sheets
        If ws.Name <> "Combined" Then
            bottomA = desWs.Range("A" & desWs.Rows.Count).End(xlUp).Row
            ws.UsedRange.Offset(1, 0).Copy desWs.Cells(desWs.Rows.Count, "B").End(xlUp).Offset(1, 0)
            LastRow = desWs.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            desWs.Cells(bottomA + 1, 1).Resize(LastRow - bottomA) = ws.Name
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub