(同じワークブック内の)7つの異なるワークシートからCombine [duplicate]という1つのワークシートにデータをコピーしようとしています。
(同じワークブック内の)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
以下のコードを試してください。エディションがマークされています。
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