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

Question

我有一本包含10個工作表的工作簿，其中6個需要合並到一個工作表中。 這6個都具有相同的標題行。 有時我可以使我的代碼正常工作。 但是，如果工作表之一為空（只有標題行），則標題將被復制到新的合並表中。

我嘗試添加一個“ On Error Resume Next”，它只能防止生成錯誤。 它仍然僅復制標題行。

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

我只需要宏副本填充標題下的行，並跳過碰巧是空白的所有工作表。

Answer 1

這樣的東西-這里的一些其他建議：

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