Получение списка подпапок из заданной папки по маске

Sub ПоискПодходящихПодпапок()
    ' считываем в колекцию coll подходящие полные пути папок
    ' (поиск папок с названием, начинающимся на 09)
    Set coll = SubFoldersCollection("d:\", "09*")
 
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к папкам
        Debug.Print coll(i) ' выводим очередной путь в окно Immediate
    Next
End Sub

Option Compare Text
 
Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection
    Set SubFoldersCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$)
    For Each folder In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
        If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Path & "\"
    Next folder
    Set FSO = Nothing
End Function

Option Compare Text
 
Sub ЗагрузкаСпискаПодпапок()
    On Error Resume Next
    ' считываем в колекцию coll подходящие полные пути папок
    Set coll = SubFoldersCollection([b1], "*") ' путь к основной папке берем из ячейки B1

    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к папкам
        Cells(i + 2, 1) = coll(i)    ' выводим очередное название папки на лист
    Next
End Sub
 
Sub Очистка()
    On Error Resume Next
    Range([A3], Range("A" & Rows.Count).End(IIf(Len(Range("A" & Rows.Count)), xlDown, xlUp))).ClearContents
End Sub
 
Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection
    Set SubFoldersCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$)
    For Each folder In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
        If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Name
    Next folder
    Set FSO = Nothing
End Function

Function FoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*", Optional ByVal SearchDeep& = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых папок Mask (будут отобраны только папки с подходящим именем)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути к найденным папкам
    ' (применяется рекурсивный вызов процедуры FindFolders)

    Set FoldersCollection = New Collection        ' создаём пустую коллекцию
    FindFolders FolderPath, Mask, FoldersCollection, SearchDeep        ' поиск
End Function
 
Function FindFolders(ByVal FolderPath$, ByVal Mask$, ByRef coll As Collection, ByVal SearchDeep&)
    ' перебирает все подпапки в папке FolderPath, используя объект FSO
    ' перебор подпапок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных папок в коллекцию coll

    Static FSO As Object: Dim current_folder As Object, folder As Object, subfolder As Object
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
 
    On Error Resume Next: Set current_folder = FSO.GetFolder(FolderPath)
    If Not current_folder Is Nothing Then        ' если удалось получить доступ к папке

        If current_folder.Name Like Mask Then coll.Add current_folder.Path & "\"
        SearchDeep = SearchDeep - 1        ' уменьшаем глубину поиска в подпапках

        For Each folder In current_folder.SubFolders        ' перебираем все подпапки в папке FolderPath
            If folder.Name Like Mask Then coll.Add folder.Path & "\"
 
            If SearchDeep Then        ' если надо искать глубже
                For Each subfolder In folder.SubFolders        ' перебираем все подпапки в очередной папке
                    FindFolders subfolder.Path, Mask, coll, SearchDeep
                Next
            End If
        Next
 
        Set current_folder = Nothing: Set folder = Nothing: Set subfolder = Nothing
    End If
End Function

Sub test_FoldersCollection()
    Dim coll As Collection, folder$
    folder$ = "D:\ПРОЕКТЫ\Excel\Примеры\"        ' папка, в которой ищем подпапки

    ' получаем список подпапок с названием из 8 цифр
    Set coll = FoldersCollection(folder$, "########")
 
    ' выводим список найденных папок в окно Immediate
    For Each Item In coll
        Debug.Print Item
    Next
End Sub