VBA copy sheets loop error

[EMcK01]

Hi,

I am trying to set up a 'master' workbook that collates worksheets from a variety of different workbook. It appears to work fine for the first run and it appears to run through everything ok within the second loop, until it gets to this section within the code

Workbooks(FileName2).Sheets(arr).Copy _
After:=Workbooks(FileName1).Sheets(LastSheet)

Then I get a run time error '9' Subscript out of Range

For contents the full script is listed below.

Sub CollateAllResSheets()


    Dim FolderPath1 As String
    
    Dim FileName1 As String
    Dim FileName2 As String
    Dim SheetName1 As String


    Dim WorkBk1 As Workbook
    Dim WorkBk2 As Workbook
    
    Dim SourceRange As Range
    Dim DestRange As Range
    
    Dim data1 As Worksheet
    Dim data2 As Worksheet
    
    Dim Src As Worksheet
    Dim Dest As Worksheet
    Dim destbks As Worksheet
    
    Set data1 = Worksheets("DATA")


    FolderPath1 = data1.Cells(5, 3)
    FileName1 = data1.Cells(4, 3)
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName2 = Dir(FolderPath1 & "*.xlsx")
    
    ' Loop until Dir returns an empty string.
    Do While FileName2 <> ""
        
        ' Open a workbook in the folder
        Set WorkBk2 = Workbooks.Open(FolderPath1 & FileName2)
        
        Workbooks(FileName1).Activate
        LastSheet = Workbooks(FileName1).Sheets(Sheets.Count).Name
        
        Application.ScreenUpdating = False


        With Sheets("WORKING").Activate
        End With


        Set wbk = Workbooks(FileName2)
        Set wbk = ActiveWorkbook
    
        Dim n As Long
        n = 3
        For i = 3 To Workbooks(FileName2).Sheets.Count
            If Workbooks(FileName2).Sheets(i).Visible = True Then
                Cells(n, 2) = Workbooks(FileName2).Sheets(i).Name
                n = n + 1
            End If
        Next i


    Dim UsdRws As Long
    Dim Rng As Range
    Dim cl As Range
    Dim Cnt As Long
    Dim arr() As Variant
    
    With Sheets("WORKING")
        UsdRws = .Range("B3").End(xlDown).Row
        Set Rng = .Range("B3:B" & UsdRws)
    End With


    For Each cl In Rng
        Cnt = Cnt + 1
        ReDim Preserve arr(1 To Cnt)
        arr(Cnt) = cl
    Next cl
    
    Workbooks(FileName2).Sheets(arr).Copy _
    After:=Workbooks(FileName1).Sheets(LastSheet)
            
        Application.ScreenUpdating = True
        
        ' Close the source workbook while saving changes.
        Workbooks(FileName2).Save
        Workbooks(FileName2).Close
        
        With Sheets("WORKING").Activate
            Range("B3:B" & UsdRws).ClearContents
        End With
        
        ' Use Dir to get the next file name.
        FileName2 = Dir()
        Loop


End Sub

Any thoughts of how to fix this issue?

Also, apologies where the above is long-winded as I have no doubt others could make what I am doing a lot quicker. While I've been trying to work with VBA, I'm still very much a novice at it.

Thanks,
EMcK

 

[JLGWhiz]

The subscript out of range message indicates that one or more of the sheets in your array cannot be found or the destination workbook cannot be found by vba. You would need to look at the value of your Sheets(arr) and determine which sheet names it holds and then check that the source workbook has those sheets, as well as make sure the destination workbook is open.

Since you are in a Do loop, you could avoid those workbooks where that condition exists by ignoring the error with this modification

On Error Resume Next
Workbooks(FileName2).Sheets(arr).Copy _
    After:=Workbooks(FileName1).Sheets(LastSheet)
On Error GoTo 0
Err.Clear

 

[EMcK01]

Hi JLGWhiz,

Thanks for your response and explanation of the error. As you said the code you have given ignores the error but doesn't fix getting the other sheets copied.
To be honest its confused me a little more, as the script copies the sheets from the first workbook it opens without a problem, it just doesn't do the remaining workbooks. Both source workbook and destination workbook remain open throughout the operation before closing the source workbook on completion. I'm not sure if there is a hangover of a reference somewhere to the name of the first workbook it opens, I'm just struggling to see it.

Thanks,
EMcK

 

[JLGWhiz]

See if this will do what you want.

Sub CollateAllResSheets2()
    Dim WorkBk1 As Workbook, WorkBk2 As Workbook, data1 As Worksheet, FolderPath1 As String
    Set WorkBk1 = ThisWorkbook
    Set data1 = WorkBk1.Worksheets("DATA")
    FolderPath1 = data1.Cells(5, 3).Value
    FileName1 = data1.Cells(4, 3).Value
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName2 = Dir(FolderPath1 & "*.xlsx")
    ' Loop until Dir returns an empty string.
    Do While FileName2 <> ""
        ' Open a workbook in the folder
        Set WorkBk2 = Workbooks.Open(FolderPath1 & FileName2)
        For i = 3 To WorkBk2.Sheets.Count
            WorkBk2.Sheets(i).Copy After:=WorkBk1.Sheets(WorkBk1.Sheets.Count)
        Next
        ' Close the source workbook while saving changes.
        WorkBk2.Close True
        ' Use Dir to get the next file name.
        FileName2 = Dir()
    Loop
End Sub

 

[EMcK01]

Hi,

It does everything I need it to do so thank you very much. One minor thing that I would like to alter, is there a way of only copying the visible sheets over and not including those that are hidden?

Thanks,
EMcK

 

[JLGWhiz]

Sub CollateAllResSheets3()
    Dim WorkBk1 As Workbook, WorkBk2 As Workbook, data1 As Worksheet, FolderPath1 As String
    Set WorkBk1 = ThisWorkbook
    Set data1 = WorkBk1.Worksheets("DATA")
    FolderPath1 = data1.Cells(5, 3).Value
    FileName1 = data1.Cells(4, 3).Value
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName2 = Dir(FolderPath1 & "*.xlsx")
    ' Loop until Dir returns an empty string.
    Do While FileName2 <> ""
        ' Open a workbook in the folder
        Set WorkBk2 = Workbooks.Open(FolderPath1 & FileName2)
        For i = 3 To WorkBk2.Sheets.Count
            [COLOR=#ffa07a]If WorkBk2.Sheets(i).Visible = True Then[/COLOR]
                WorkBk2.Sheets(i).Copy After:=WorkBk1.Sheets(WorkBk1.Sheets.Count)
           [COLOR=#ffa07a]End If
[/COLOR]       Next
        ' Close the source workbook while saving changes.
        WorkBk2.Close True
        ' Use Dir to get the next file name.
        FileName2 = Dir()
    Loop
End Sub

 

[EMcK01]

JLGWhiz,

Thank you very much, thats excellent. I sincerely appreciate you taking the time to look at this and significantly simply what I was doing.

Thanks again.
EMcK

 

[JLGWhiz]

JLGWhiz,

Thank you very much, thats excellent. I sincerely appreciate you taking the time to look at this and significantly simply what I was doing.

Thanks again.
EMcK

You're welcome,
Regards, JLG