Cycle through sub-folders and files in a user-specified root directory

Question

My cycling script through individual files works fine, but I now need it to also look through/for multiple directories. I am stuck....

The order things need to happen:

• User is prompted to choose root directory of what they need
• I need the script to look for any folders in that root directory
• If the script finds one, it opens the first one (all folders, so no specific search filter for the folders)
• Once open, my script will loop through all files in the folders and do what it needs to do
• after it's finished it closes the file, closes the directory and moves to the next one, etc..
• Loops until all folders have been opened/scanned

This is what I have, which doesn't work and I know is wrong:

MsgBox "Please choose the folder."
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "\\blah\test\"
    .AllowMultiSelect = False
    If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
    CSRootDir = .SelectedItems(1)
End With
folderPath = Dir(CSRootDir, "\*")

Do While Len(folderPath) > 0
    Debug.Print folderPath
    fileName = Dir(folderPath & "*.xls")
    If folderPath <> "False" Then
        Do While fileName <> ""
            Application.ScreenUpdating = False
            Set wbkCS = Workbooks.Open(folderPath & fileName)

            --file loop scripts here

        Loop  'back to the Do
Loop    'back to the Do

Final Code. It cycles through all sub-directories and files in each sub-directory.

Dim FSO As Object, fld As Object, Fil As Object
Dim fsoFile As Object 
Dim fsoFol As Object 
Dim fileName As String

    MsgBox "Please choose the folder."
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFolderPicker)
         .InitialFileName = "\\blah\test\"
         .AllowMultiSelect = False
         If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
         folderPath = .SelectedItems(1)
    End With

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
         Set FSO = CreateObject("Scripting.FileSystemObject")
         Set fld = FSO.getfolder(folderPath)
    If FSO.folderExists(fld) Then
         For Each fsoFol In FSO.getfolder(folderPath).subfolders
              For Each fsoFile In fsoFol.Files
                   If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then
    fileName = fsoFile.Name
    Application.ScreenUpdating = False
    Set wbkCS = Workbooks.Open(fsoFile.Path)

    'My file handling code


                End If
              Next
         Next
    End If

Answer 1

You might find it easier to use the FileSystemObject, somthing like this

This dumps a folder/file list to the Immediate window

Option Explicit

Sub Demo()
    Dim fso As Object 'FileSystemObject
    Dim fldStart As Object 'Folder
    Dim fld As Object 'Folder
    Dim fl As Object 'File
    Dim Mask As String
    
    Set fso = CreateObject("scripting.FileSystemObject") ' late binding
    'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
    
    Set fldStart = fso.GetFolder("C:\Your\Start\Folder") '-- use your FileDialog code here

    Mask = "*.xls"
    Debug.Print fldStart.Path & "\"
    ListFiles fldStart, Mask
    For Each fld In fldStart.SubFolders
        ListFiles fld, Mask
        ListFolders fld, Mask
    Next
End Sub


Sub ListFolders(fldStart As Object, Mask As String)
    Dim fld As Object 'Folder
    For Each fld In fldStart.SubFolders
        Debug.Print fld.Path & "\"
        ListFiles fld, Mask
        ListFolders fld, Mask
    Next

End Sub

Sub ListFiles(fld As Object, Mask As String)
    Dim fl As Object 'File
    For Each fl In fld.Files
        If fl.Name Like Mask Then
            Debug.Print fld.Path & "\" & fl.Name
        End If
    Next
End Sub

Answer 2

Here is a VBA solution, without using external objects.

Because of the limitations of the Dir() function you need to get the whole content of each folder at once, not while crawling with a recursive algorithm.

Function GetFilesIn(Folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(Folder & "\*")
  Do While F <> ""
    GetFilesIn.Add F
    F = Dir
  Loop
End Function

Function GetFoldersIn(Folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(Folder & "\*", vbDirectory)
  Do While F <> ""
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
    F = Dir
  Loop
End Function

Sub Test()
  Dim C As Collection, F

  Debug.Print
  Debug.Print "Files in C:\"
  Set C = GetFilesIn("C:\")
  For Each F In C
    Debug.Print F
  Next F

  Debug.Print
  Debug.Print "Folders in C:\"
  Set C = GetFoldersIn("C:\")
  For Each F In C
    Debug.Print F
  Next F
End Sub

Answer 3

Sub MoFileTrongCacFolder()

    Dim FSO As Object, fld As Object, Fil As Object
    Dim fsoFile As Object
    Dim fsoFol As Object
    Dim fileName As String
    Dim folderPath As String
    Dim wbkCS As Object

    MsgBox "Please choose the folder."
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "\\blah\test\"
        .AllowMultiSelect = False
        If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
        folderPath = .SelectedItems(1)
    End With

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.getfolder(folderPath)
    If FSO.folderExists(fld) Then
        For Each fsoFol In FSO.getfolder(folderPath).subfolders
            For Each fsoFile In fsoFol.Files
                If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then
                    fileName = fsoFile.Name
                    Application.ScreenUpdating = False
                    Set wbkCS = Workbooks.Open(fsoFile.Path)

                    'My file handling code


                End If
            Next
        Next
    End If
End Sub