Looping through subfolders

Hello

I have a programme that updates a master workbook (performq2y.xlsx) with data from worksheets contained in 24 workbooks in a specific source folder ("c:\data\persist2y\persistance_2y120"). The problem now is that I have 120 folders (again each with 24 workbooks) in the source folder (last three digits of source folder run from1 to 120). I want to update the master workbook with data from 2,880 (24 x 120) worksheets from all the worksheets contained in the 120 folders. I could run my existing VBA programme 120 times, but that seems very silly. Is there a way to adapt my VBA programme to do this all in one step? I attach my existing programme.

Private Sub CommandButton1_Click()


    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rng4 As Range
    Dim rng5 As Range
    Dim rng6 As Range
    Dim rng7 As Range
    Dim rng8 As Range
    Dim rng9 As Range
    Dim rng10 As Range
    Dim rng11 As Range
    Dim rng12 As Range
    Dim rng13 As Range
    Dim rng14 As Range
    Dim Master As Workbook
    Dim sourceBook As Workbook
    Dim sourceData As Worksheet
    Dim CurrentFileName As String
    Dim myPath As String
    Dim lrow As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
     Set Master = wb1
     
     Set wb1 = Workbooks.Open(Filename:="c:\data\persistresults\performq2y.xlsx")
     Set ws1 = wb1.Worksheets("BystrategySRd")
     myPath = "c:\data\persist2y\persistance_2y120"
     CurrentFileName = Dir(myPath & "\*.xls")
 Do
    Workbooks.Open (myPath & "\" & CurrentFileName)
    Set sourceBook = Workbooks(CurrentFileName)
    Set sourceData = sourceBook.Worksheets(9)
    
     Set rng1 = ws1.Range("b65536").End(xlUp).Offset(1, 0)
     Set rng2 = ws1.Range("c65536").End(xlUp).Offset(1, 0)
     Set rng3 = ws1.Range("d65536").End(xlUp).Offset(1, 0)
     Set rng4 = ws1.Range("e65536").End(xlUp).Offset(1, 0)
     Set rng5 = ws1.Range("f65536").End(xlUp).Offset(1, 0)
     Set rng6 = ws1.Range("g65536").End(xlUp).Offset(1, 0)
     Set rng7 = ws1.Range("h65536").End(xlUp).Offset(1, 0)
     Set rng8 = ws1.Range("i65536").End(xlUp).Offset(1, 0)
     Set rng9 = ws1.Range("j65536").End(xlUp).Offset(1, 0)
     Set rng10 = ws1.Range("k65536").End(xlUp).Offset(1, 0)
     Set rng11 = ws1.Range("l65536").End(xlUp).Offset(1, 0)
     Set rng12 = ws1.Range("m65536").End(xlUp).Offset(1, 0)
     Set rng13 = ws1.Range("n65536").End(xlUp).Offset(1, 0)
     Set rng14 = ws1.Range("o65536").End(xlUp).Offset(1, 0)
     
     
With sourceData
            
    rng1 = sourceData.Range("b4")
    rng2 = sourceData.Range("b5")
    rng3 = sourceData.Range("b6")
    rng4 = sourceData.Range("b7")
    rng5 = sourceData.Range("b8")
    rng6 = sourceData.Range("b9")
    rng7 = sourceData.Range("b10")
    rng8 = sourceData.Range("b11")
    rng9 = sourceData.Range("b12")
    rng10 = sourceData.Range("b13")
    rng11 = sourceData.Range("b14")
    rng12 = sourceData.Range("b15")
    rng13 = sourceData.Range("b16")
    rng14 = sourceData.Range("b17")
    
End With
       
    sourceBook.Close
  
'Calling DIR w/o argument finds the next .xlsx file within the current directory.
CurrentFileName = Dir()
Loop While CurrentFileName <> ""

wb1.Save
wb1.Close

MsgBox "Done Did It!"

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub