vba subfolder list

' List of subfolders
' Needs to add "Microsoft Scripting Runtime" reference to your file
Sub SubFoldersInfo(ByVal pFolder As String, ByRef pColFolders As Collection, _
    Optional ByVal pMe As Boolean)
    Dim sFolder As String
    Dim oFSO As New FileSystemObject
    Dim oFolder, oSubFolder As Folder
    
    sFolder = IIf(Right(pFolder, 1) <> "\", pFolder & "\", pFolder)
    Set oFolder = oFSO.GetFolder(sFolder)
    If pMe Then
        pColFolders.Add oFolder
    End If
    For Each oSubFolder In oFolder.SubFolders
        pColFolders.Add oSubFolder
        SubFoldersInfo oSubFolder.Path, pColFolders, False
    Next
End Sub
'------------------------------------------------------------------------------
Sub TestMe()
    Dim colFolders As New Collection, sFolderPath As Variant
    SubFoldersInfo ThisWorkbook.Path, colFolders, True
    For Each sFolderPath In colFolders
        Debug.Print sFolderPath.ShortName & " : "; sFolderPath.Path
    Next sFolderPath
End Sub