Loop Excel VBA script Through Worksheets Not Functioning

Question

I 'borrowed' and pieced together code from various SO and other forum posts to create an Excel VBA script in a master workbook which will:

• Wipe the original destination cells 'clean'
• Ask user to choose a source workbook
• Select and copy a range of cells from the source
• Paste in to master workbook in the next open row

This code functions - for one source worksheet only - and is as follows:

Sub Copy_Data_Test()

Range("A2:N750").ClearContents

'Set primary variables
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long

Set WS = Worksheets("SIS Agregate")
With WS
    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
End With

Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant

'Set copy destination
Set wb = ActiveWorkbook

'Request to open copy source
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select One File To Open", , False)
'Exit if no copy source chosen
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

'Set copy source variable
Set wb2 = ActiveWorkbook

'Select range to copy
wb2.Worksheets("032_Laguna_Hills").Select
Range("A2:M100").Select
Selection.Copy

'Paste in Copy Destination
wb.Activate
wb.Worksheets("SIS Agregate").Range("A" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

My goal is to have this loop through approx. 50 worksheets. To do this, I found a suggestion from this SO post to use a For Each/Next loop to cycle through worksheets and copy the same range of cells.

I am attempting to wrap the processing code, as suggested, with no success. The macro halts when it hits this loop. What I have done wrong or where I have misplaced this code? (I have included only the changed code past opening the source workbook).

'Set copy source variable
Set wb2 = ActiveWorkbook
Set ws2 = Worksheet

'Select range to copy
For Each ws2 In wb2.Sheets
Range("A2:M100").Select
Selection.Copy

'Paste in Copy Destination
wb.Activate
wb.Worksheets("SIS Agregate").Range("A" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
Next ws2

End Sub

No error text is provided; the VBA debugger opens with yellow highlights at either Set ws2 = Worksheet or For Each ws2 IN wb2.Sheets so it seems the problem is early on, but not sure what to do about it. I'm also concerned I'm not swapping between workbooks correctly and this could also be a problem.

Answer 1

Okay, this likely isn't the cleanest method but until I can refine this it is working solidly for 50 sheets. I used the suggestions above to properly iterate the last row within the loop.

Sub Copy_Box_Data()

Range("A2:N5000").ClearContents

Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long

Set WS = Worksheets("SIS Agregate")
With WS
    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
End With

Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant

Set wb = ActiveWorkbook

vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select One File To Open", , False)

If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

Set wb2 = ActiveWorkbook

For Each sh In wb2.Worksheets
    sh.Range("A2:M200").Copy
    wb.Activate
    wb.Worksheets("SIS Agregate").Range("A" & LastCellRowNumber).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set LastCell = wb.ActiveSheet.Cells(wb.ActiveSheet.Rows.Count, "A").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
Next

End Sub

Answer 2

You don't need to Set ws2, just Dim it. The For Each does the Setting.