Excel VBA: How to change code to loop through multiple folders

Question

This post is related to my previous question HERE.

In the workbook "CountResults.xlsm", I have a code that traverses through different excel files in the same folder and counts the number of "YES" in a specific column from each file. It then pastes the count in "CountResults.xlsm".

This is how the folder previously looked like :

Now my issue is, my Test files are going to be within two more Folders so my code is not able to pick it up. It starts with a folder called 'CodeResults', then folder 'Test0X', then 'S', and then the file name.

ex. CodeResults -> Test01 -> S -> Test01.xls

This is what my Folder currently looks like:

This is my current code that I need to alter so that it can read the excel files within each folder:

Private Sub CommandButton1_Click()

    Dim r As Range
    With Worksheets("Sheet1")
        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            r.Offset(0, 1).Value = getYesCount(r.Value)
        Next
    End With
End Sub

Function getYesCount(WorkBookName As String) As Long
    Const FolderPath As String = "C:\Users\khanr1\Desktop\Excel_TEST\CodeUpdateTest"

    If Len(Dir(FolderPath & WorkBookName)) Then
        With Workbooks.Open(FolderPath & WorkBookName)
            With .Worksheets("Sheet2")
                 getYesCount = Application.CountIfs(.Range("D:D"), "YES", _
                                     .Range("B:B"), "*", _
                                     .Range("A:A"), "1")
            End With
            .Close False
        End With
    Else
        Debug.Print FolderPath & WorkBookName; ": Not Found"
    End If
End Function

For reference, this is what my Test01.xls looks like:

This is what my CountResults.xlsm looks like:

NOTE: I was trying to figure out a solution. I currently use the names 'A' column in CountResults.xlsm to find the files. So for example, I can open the Folder Test01 by pulling the name from this column.

Answer 1

You need to so this with a recursive loop. I'll give you two samples that do kind of the same thing.

Option Explicit

Sub ListAllFiles()
    'searchForFiles "c:\tushar\temp\", "processOneFile", "*.*", True, True
    searchForFiles "C:\Users\your_path_here\Desktop\Work Samples\", "writefilestosheet", "*.*", True, True
End Sub

Sub processOneFile(ByVal aFilename As String)
    Debug.Print aFilename
End Sub

Sub writeFilesToSheet(ByVal aFilename As String)
    With ActiveSheet
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename
        End With
End Sub


    Private Sub processFiles(ByVal DirToSearch As String, _
            ByVal ProcToCall As String, _
            ByVal FileTypeToFind As String)
        Dim aFile As String
        aFile = Dir(DirToSearch & FileTypeToFind)
        Do While aFile <> ""
            Application.Run ProcToCall, DirToSearch & aFile
            aFile = Dir()
            Loop
End Sub

Private Sub processSubFolders(ByVal DirToSearch As String, _
            ByVal ProcToCall As String, _
            ByVal FileTypeToFind As String, _
            ByVal SearchSubDir As Boolean, _
            ByVal FilesFirst As Boolean)

Dim aFolder As String, SubFolders() As String

ReDim SubFolders(0)

aFolder = Dir(DirToSearch, vbDirectory)

    Do While aFolder <> ""

        If aFolder <> "." And aFolder <> ".." Then

            If (GetAttr(DirToSearch & aFolder) And vbDirectory) _
                    = vbDirectory Then
                SubFolders(UBound(SubFolders)) = aFolder
                ReDim Preserve SubFolders(UBound(SubFolders) + 1)
                End If
                End If
            aFolder = Dir()
            Loop

        If UBound(SubFolders) <> LBound(SubFolders) Then
            Dim i As Long
            For i = LBound(SubFolders) To UBound(SubFolders) - 1
                searchForFiles _
                    DirToSearch & SubFolders(i), _
                    ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst
                Next i
            End If

    End Sub

Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _
        Optional ByVal FileTypeToFind As String = "*.*", _
        Optional ByVal SearchSubDir As Boolean = False, _
        Optional ByVal FilesFirst As Boolean = False)
    On Error GoTo ErrXIT
    If Right(DirToSearch, 1) <> Application.PathSeparator Then _
        DirToSearch = DirToSearch & Application.PathSeparator

If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind
If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _
    FileTypeToFind, SearchSubDir, FilesFirst

    If Not FilesFirst Then _
        processFiles DirToSearch, ProcToCall, FileTypeToFind
    Exit Sub
ErrXIT:
    MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")"
    Exit Sub
End Sub

ALSO

Option Explicit

Sub TestListFolders()

    Application.ScreenUpdating = False

     'create a new workbook for the folder list

     'commented out by dr
     'Workbooks.Add

     'line added by dr to clear old data
    Cells.Delete

     ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With

    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "Folder Name:"
    Range("C3").Formula = "Size:"
    Range("D3").Formula = "Subfolders:"
    Range("E3").Formula = "Files:"
    Range("F3").Formula = "Short Name:"
    Range("G3").Formula = "Short Path:"
    Range("A3:G3").Font.Bold = True

     'ENTER START FOLDER HERE
     ' and include subfolders (true/false)
    ListFolders "C:\Users\your_path_here\Desktop\Work Samples\", True

    Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

     'line added by dr for repeated "Permission Denied" errors

    On Error Resume Next

     ' display folder properties
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, 1).Formula = SourceFolder.Path
    Cells(r, 2).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If

    Columns("A:G").AutoFit

    Set SourceFolder = Nothing
    Set FSO = Nothing

     'commented out by dr
     'ActiveWorkbook.Saved = True

End Sub