VBA code to cycle through all parent folder and sub folders

[VBA learner ITG]

Hi Experts,

I need your guidance. I have the below code whoch was written to cycle through all files in a folder.

Now im faced with a challenge of having multiple sub folders upon sub folder within the parent folder.

Is it possible to adapt this code to loop through Parent folder and its sub folders and perform its task.

Sub RunAll()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As fileDialog
    ''///Retrieve Target Folder Path From User
    Set FldrPicker = Application.fileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & Application.PathSeparator
    End With
    Application.ScreenUpdating = False
    ''///In Case of Cancel
NextCode:
    myPath = myPath
    If myPath = "" Then Exit Sub
    


    ''///Target File Extension (must include wildcard "*")
    myExtension = "*.xls*"
    
    ''///Target Path with Ending Extension
    myFile = Dir(myPath)
    Call LoopExcelFiles(myPath, "*.xls*")

    MsgBox iCnt & " files processed"


    For Each wb In Workbooks
        If wb.Name <> ThisWorkbook.Name Then wb.Close True
    Next wb
    Application.ScreenUpdating = True
End Sub

 

[Kaper]

1) real looping goes in LoopExcelFiles procedure - you have not shown it's contents

2) sample of complete set for similar task (note comments in red in the middle of the code):

Sub RunAll() 'run this one
    Dim Tbl As Variant, i&, x&, , mypath$
    Dim FldrPicker As fileDialog
    Set FldrPicker = Application.fileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then exit sub
        myPath = .SelectedItems(1) & Application.PathSeparator
    End With
    Application.ScreenUpdating = False
    Call ListFiles(mypath, Tbl, "*.xls") 

    x = UBound(Tbl) 
    ReDim Tbl_Out(1 To x, 1 To 1) 
    For i = 1 To x 
        Tbl_Out(i, 1) = Tbl(i) 
    Next i 
    Cells(1).Resize(x).Value = Tbl_Out 

End Sub 

Sub ListFiles(ByVal sFolder As String, ByRef varrFiles As Variant, sFilter As String) 

'--------------------------------------------------------------------------------------- 
' Procedure : ListFiles 
' DateTime  : 08.12.2013 (adopted some time 2016)
' Author  : Artik (by Kaper)
' sFolder -   obowiązkowy; wskazany folder 
' varrFiles - obowiązkowy; zmienna typu Variant, 
'       do której zostanie przekazana tablica znalezionych plików 
' sFilter -   wzorzec wg którego poszukiwane są pliki 
'--------------------------------------------------------------------------------------- 
' 

    Dim FSO As Object    'Scripting.FileSystemObject 
    Dim fsoFolder As Object    'Scripting.Folder 
    Dim fsoSubFolders As Object    'Scripting.Folders 
    Dim fsoSubFolder As Object    'Scripting.Folder 
    Dim fsoFile As Object   'Scripting.File 
    Dim i As Long, vSubFolders as boolean

    Set FSO = CreateObject("Scripting.FileSystemObject") 

    If FSO.FolderExists(sFolder) Then 
        Set fsoFolder = FSO.GetFolder(sFolder) 
        Set fsoSubFolders = fsoFolder.SubFolders 

        vSubFolders = fsoSubFolders.Count > 0
        For Each fsoFile In fsoFolder.Files 
            Application.StatusBar = "folder: " & fsoFolder.Path 

            If UCase(fsoFile.Name) Like UCase(sFilter) Then 
                If IsEmpty(varrFiles) Then 
                    ReDim varrFiles(1 To 1) 
                End If 

                i = UBound(varrFiles) 

                If IsEmpty(varrFiles(i)) Then 
                    i = i - 1 
                End If 

                i = i + 1 

                ReDim Preserve varrFiles(1 To i) 

                varrFiles(i) = fsoFile.Path    'pełne odwołanie 

[COLOR="#FF0000"]' so here you have a complete path for a file in the structure
' it is stored in an array, and finally written to a workseet, but
' of course could be processed here[/COLOR]

            End If    'UCase(fsoFile.Name) Like UCase(sFilter) 

        Next fsoFile 

' now subfolders !!!
        For Each fsoSubFolder In fsoSubFolders 
          Call ListFiles(fsoSubFolder.Path, varrFiles, sFilter) 
        Next fsoSubFolder 

    End If    

    Set fsoSubFolders = Nothing 
    Set fsoFolder = Nothing 
    Set FSO = Nothing 

    Application.StatusBar = False 
End Sub