Excel VBA：如何在同一工作簿中合并特定的工作表？

Question

I have a workbook with 10 worksheets, 6 of which need to be consolidated into a single worksheet. Those 6 all have the same header row. I can get my code to work some of the time. However, if one of the worksheets is empty (only has the header row), the header will be copied to the new consolidated sheet.

I have tried adding an "On Error Resume Next", which only prevents an error from being generated. It still only copies the header row.

Sub Combine()
    Dim s As Worksheet

    On Error Resume Next
    Application.DisplayAlerts = False

    Sheets("All").Delete 'These sheets don't need to be kept or consolidated
    Sheets("005").Delete
    Sheets("006").Delete
    Sheets("007").Delete

    Application.DisplayAlerts = True
    On Error GoTo 0

    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "0"

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

    For Each s In ActiveWorkbook.Sheets
            If s.Name <> "0" Then
                Application.GoTo Sheets(s.Name).[a1]
                Selection.CurrentRegion.Select
                'On Error Resume Next
                Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
                Selection.Copy Destination:=Sheets("0"). _
                Cells(Rows.Count, 1).End(xlUp)(2)
                'On Error GoTo 0
            End If
        Next
End Sub

I need to have the macro copy only filled rows below the header and skip over any sheets that happen to be blank.

Answer 1

Something like this -some other suggestions in here:

Sub Combine()

    Dim s As Worksheet, wb As Workbook, wsDest As Worksheet, rngCopy As Range

    Set wb = ActiveWorkbook  '<< always specify a workbook

    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets("All").Delete 'These sheets don't need to be kept or consolidated
    wb.Sheets("005").Delete
    wb.Sheets("006").Delete
    wb.Sheets("007").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'get a direct reference to the newly-added sheet
    Set wsDest = wb.Worksheets.Add(before:=wb.Worksheets(1))
    wsDest.Name = "0"

    wb.Sheets(2).Range("A1").EntireRow.Copy Destination:=wsDest.Range("A1")

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> wsDest.Name Then    '<< remove hard-coded name
            Set rngCopy = s.Range("A1").CurrentRegion
            'check how many rows before copying
            If rngCopy.Rows.Count > 1 Then
                'no need for select/activate
                rngCopy.Offset(1, 0).Resize(rngCopy.Rows.Count - 1).Copy _
                   wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
        End If
    Next s
End Sub