Макросы в Excel

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