Loop required to merge worksheet data

[Grey Old Man]

My code below works OK:

Private Sub Worksheet_Activate()
On Error GoTo Error:
Application.ScreenUpdating = False
Dim SourceSheetA As String
Dim SourceSheetB As String
Dim TargetSheet As String
Dim StartCopy As String
Dim EndColumn As String
Dim CountA As Long
Dim CountB As Long
Dim CountC As Long
'--------------------------------------------------
SourceSheetA = "My data"
SourceSheetB = "New Data"
TargetSheet = "Combined"
StartCopy = "A2"
EndColumn = "J"
'--------------------------------------------------
CountA = Sheets(SourceSheetA).Cells(Cells.Rows.Count, "A").End(xlUp).Row
CountB = Sheets(SourceSheetB).Cells(Cells.Rows.Count, "A").End(xlUp).Row
CountC = CountA + CountB
'--------------------------------------------------
Worksheets(SourceSheetA).Range(StartCopy & ":" & EndColumn & CountA).Copy
Worksheets(TargetSheet).Range(StartCopy & ":" & EndColumn &
CountA).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'--------------------------------------------------
Worksheets(SourceSheetB).Range(StartCopy & ":" & EndColumn & CountB).Copy
Worksheets(TargetSheet).Range("A" & CountA + 1 & ":" & EndColumn &
CountC).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("A1").Select
'--------------------------------------------------
Exit Sub
Error:
MsgBox "Error"
End Sub



I need to expand this to include dozens more worksheets, perhaps by listing
them all in a string (? array). This list would need to be changed on a
regular basis.

Can anyone help in writing a loop to copy all of the data in all of the
worksheets nominated in the list?

I could always repeat the code for each worksheet but this seems a bit
cumbersome and high maintenance.

Thanks in anticipation.

 

[Don Guillett]

Try this in the THISWORKBOOK module

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
For Each Sh In Sheets(Array("sheet1", "sheet10"))
If Sh.Name = ActiveSheet.Name Then MsgBox Sh.Range("a1")
Next Sh
End Sub

 

[Jacob Skaria]

Try the below...

Sub Macro()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngWorkSheets As Range, lngRow As Long

'Mention the range of source sheets
Set rngWorkSheets = Sheets("Sheet1").Range("A1:A10")

'Edit the target sheet name
Set ws2 = Worksheets("Target")

Application.ScreenUpdating = False
For Each cell In rngWorkSheets
Set ws1 = Worksheets(CStr(cell.Text))
lngRow = ws2.Cells(Cells.Rows.Count, "A").End(xlUp).Row

ws1.UsedRange.Copy
ws2.Range("A" & lngRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub