I use the below code to loop through a list of data and search through all the sub-folders in a given folder for files which match my requirements. Right now it takes this code about 22 minutes to run, and after a "quick" time study, I found it takes me about the same amount of time to do this step manually. I'm fairly green when it comes to VBA loops, and I'm sure the reason for the long runtime is all the looping.
I was hoping someone could review the code and find some ways for me to optimize the code to help it run quicker.
Sub loopAllSubFolderSelectStartDirectory()
Dim FSOLibrary As FileSystemObject
Dim FSOFolder As Object
Dim folderName As String
Dim rowNums As Variant
Debug.Print Time
lrow = ThisWorkbook.Sheets("240812").Range("D1048576").End(xlUp).Row
Debug.Print lrow
For i = 3 To lrow
rowNums = i
folderName = "C:\Users\jdesantis\Documents\temp240813\"
Set FSOLibrary = New FileSystemObject
LoopAllSubFolders FSOLibrary.GetFolder(folderName), rowNums
Next i
Debug.Print Time
End Sub
Sub LoopAllSubFolders(FSOFolder As Object, rowNum As Variant)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim PartNumber As String
Dim PurchaseOrder As String
PartNumber = Cells(rowNum, 4).Value
PurchaseOrder = Cells(rowNum, 5).Value
For Each FSOSubFolder In FSOFolder.SubFolders
LoopAllSubFolders FSOSubFolder, rowNum
Next
For Each FSOFile In FSOFolder.Files
If FSOFile.Path Like "*" & PartNumber & "-*-20##-" & PurchaseOrder & ".xlsx" Then
Cells(rowNum, 8).Value = "Inspected"
End If
Next
End Sub
Thanks for the suggestion jkpieterse, I was able to cut the time down to only a few minutes using the below code:
Sub GetFiles()
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object, sf
Dim i As Integer, colFolders As New Collection, ws As Worksheet
Debug.Print Time
Application.ScreenUpdating = False
Set ws = Worksheets("Inspected")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("C:\Users\jdesantis\Documents\temp240813\")
colFolders.Add oFolder 'start with this folder
Do While colFolders.Count > 0 'process all folders
Set oFolder = colFolders(1) 'get a folder to process
colFolders.Remove 1 'remove item at index 1
For Each oFile In oFolder.Files
If oFile.Name Like "######-*-20##-###.xlsx*" Then
With ws
'ws.Cells(i + 1, 1) = oFile.Name
.Cells(i + 1, 1).Value = "'" & Mid(oFile.Name, 1, 6) & Mid(oFile.Name, Len(oFile.Name) - 7, 3)
i = i + 1
End With
End If
Next oFile
'add any subfolders to the collection for processing
For Each sf In oFolder.SubFolders
colFolders.Add sf
Next sf
Loop
Debug.Print Time
Application.ScreenUpdating = True
End Sub
```
