Speed up Looping through subfolders

[Djblois]

I have this code that loops through a folder and adds all the subfolders in a combobox. It works but it is very slow because there are 100s of subfolders. They all named after the date they were uploaded. eg. 20230105. I don't need all the folders. Only the last like 2 or 3 years. If maybe it is possible to only get only the most recent. Is there any way to speed this up?


Private Sub cmdGetSubfolder_Click()


Dim fsoFile As FileSystemObject: Set fsoFile = New FileSystemObject
Dim fldFile As Object: Set fldFile = fsoFile.GetFolder(Me.tbPath)
Dim fldCount As Integer: fldCount = 0

On Error GoTo sub_error
Application.ScreenUpdating = False
Dim subFolder As Object: For Each subFolder In fldFile.SubFolders
If CLng(Left(subFolder.Name, 4)) > Year(Date) - 2 Then
fldCount = fldCount + 1
Me.cobFolderDate.AddItem subFolder.Name
End If
Next subFolder


Set fsoFile = Nothing
Set fldFile = Nothing

Application.ScreenUpdating = True
Exit Sub
sub_error:
MsgBox "There is an issue with the path"
Exit Sub


End Sub

[Paul_Hossler]

One thing to try would be to load the subfolder names into an array and then load the array instead of one at a time



Option Explicit


Private Sub cmdGetSubfolder_Click()
Dim fsoFile As FileSystemObject: Set fsoFile = New FileSystemObject
Dim fldFile As Object: Set fldFile = fsoFile.GetFolder("c:\users\daddy")
Dim fldCount As Integer: fldCount = 1

On Error GoTo sub_error
Application.ScreenUpdating = False
Dim subFolder As Object

Dim arySubfolders() As String
ReDim arySubfolders(1 To 1000)

For Each subFolder In fldFile.SubFolders
' If CLng(Left(subFolder.Name, 4)) > Year(Date) - 2 Then
arySubfolders(fldCount) = subFolder.Name
fldCount = fldCount + 1
' End If
Next subFolder


ReDim Preserve arySubfolders(1 To fldCount - 1)


Me.cobFolderDate.List = arySubfolders
Me.cobFolderDate.ListIndex = 0




Set fsoFile = Nothing
Set fldFile = Nothing

Application.ScreenUpdating = True
Exit Sub


sub_error:
MsgBox "There is an issue with the path"
Exit Sub




End Sub