(同じワークブック内の)7つの異なるワークシートからCombine [duplicate]という1つのワークシートにデータをコピーしようとしています。

Dec 23 2020

(同じワークブック内の)7つの異なるワークシートからCombineという1つのワークシートにデータをコピーしようとしています。また、コピーしないように「概要」というシートが必要です。次に、7つのワークシートをコピーした後、それらを削除する必要があります。

これは私がこれまでに得たものですが、ワークシート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



回答

Tomasz Dec 23 2020 at 15:56

以下のコードを試してください。エディションがマークされています。

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