Ich versuche, Daten aus 7 verschiedenen Arbeitsblättern (in derselben Arbeitsmappe) in ein Arbeitsblatt mit dem Namen Combine [duplicate] zu kopieren.

Question

Ich versuche, Daten aus 7 verschiedenen Arbeitsblättern (in derselben Arbeitsmappe) in ein Arbeitsblatt namens Kombinieren zu kopieren. Ich brauche auch ein Blatt namens "Zusammenfassung", um nicht kopiert zu werden. und nachdem die 7 Arbeitsblätter kopiert wurden, müssen sie gelöscht werden.

Dies ist, was ich bisher bekommen habe, aber es kopiert nur das Arbeitsblatt ACT

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("ACT").Delete 'These sheets don't need to be kept or consolidated
    wb.Sheets("VIC").Delete
    wb.Sheets("NSW").Delete
    wb.Sheets("QLD").Delete
    wb.Sheets("NT").Delete
    wb.Sheets("SA").Delete
    wb.Sheets("WA").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 = "Combine"

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

    For Each s In ActiveWorkbook.Sheets
        If s.Name <> "Summary" 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

Answer 1

Versuchen Sie es unter dem Code. Die Edition ist markiert.

Sub Combine()
Dim rngCopy As Range                        '<< edited visual
Dim wb As Workbook                          '<< edited visual
Dim s As Worksheet, wsDest As Worksheet     '<< edited visual

Application.DisplayAlerts = False   '<< edited
Application.EnableEvents = False    '<< edited
Application.ScreenUpdating = False  '<< edited

Set wb = ThisWorkbook  '<< edited
'get a direct reference to the newly-added sheet
Set wsDest = wb.Worksheets.Add(before:=wb.Worksheets(1))    '<< edited visual
wsDest.Name = "Combine"                                     '<< edited visual
wb.Worksheets(2).Rows(1).EntireRow.Copy Destination:=wsDest.Range("A1")         '<< edited

For Each s In wb.Worksheets     '<< edited
    If s.Name = "ACT" Or s.Name = "VIC" Or s.Name = "NSW" Or _
        s.Name = "QLD" Or s.Name = "NT" Or s.Name = "SA" Or s.Name = "WA" Then  '<< edited
        s.Delete                                                                '<< edited
    ElseIf s.Name <> "Summary" 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

Application.DisplayAlerts = True    '<< edited
Application.EnableEvents = True     '<< edited
Application.ScreenUpdating = True   '<< edited
End Sub