VBA copy sheets loop error

EMcK01

Board Regular
Joined
Jun 14, 2015
Messages
125
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
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.

Code:
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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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
Code:
On Error Resume Next
Workbooks(FileName2).Sheets(arr).Copy _
    After:=Workbooks(FileName1).Sheets(LastSheet)
On Error GoTo 0
Err.Clear
 
Last edited:
Upvote 0
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
 
Upvote 0
See if this will do what you want.

Code:
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
 
Last edited:
Upvote 0
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
 
Upvote 0
Code:
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
 
Last edited:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,044
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top