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

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