mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

Данный макрос позволяет получить список папок, расположенных в выбранной папке (каталоге)

Если надо получить список папок, имена которых удовлетворяют определённому критерию, используйте маску поиска (параметр Mask$)

Код функции и пример использования:

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

 

В этом примере та же функция используется для вывода названий подпапок на лист Excel:

загрузка списка подпапок

Код немного изменён:

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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Ринат, в статье ведь есть готовое решение: функция FoldersCollection

Добрый день всем!
Подскажите, пожалуйста, как в данный фрагмент кода вставить или как его изменить, чтобы он искал файлы не только в папке с рабочей книгой, но и в подпапках
Path = ThisWorkbook.Path
f = Dir(Path + "\\*_2015.xls")
Заранее спасибо!
Do While f <> ""
If Len(f) < 50 Then

Спасибо! Вопрос а как изменить код чтоб выводились все подпапки из требуемой папки?

Всё работает!!!!!!! Большущее спасибо!! Вы меня выручили уже второй раз!!!!!!!

После строки

Cells(i + 2, 1) = coll(i)    ' выводим очередное название папки на лист

добавьте строку

' добавляем гиперссылку в ячейку
        Cells.Hyperlinks.Add Cells(i + 2, 1), [b1] & "\" & coll(i), "", _
                       "Щелкните, чтобы открыть папку " & coll(i)

Здравствуйте! Ещё раз хочу поблагодарить за когда-то проделанную работу для меня (до сих пор пользуюсь и радуюсь) http://excelvba.ru/code/FoldersList.
И хотелось бы опять попросить о небольшом одолжении (так как в макросах не сильна). Мне вот этот бы макрос, под которым пишу комментарий) чуть чуть усовершенствовать. Что бы подпапки были ссылками на искомое место. Не прошу переделывать по новой, напишите какую строчку куда вставить. Заранее Благодарствую.

Выводить какие пути? К папкам или файлам? В каком виде?

Что означает фраза "общая папка всех подпапок"? Я не понимаю, о чем речь...

Добрый день.А если хочется что бы выводил пути из общей папки всех подпапок?

ошибся, все работает

А должен быть? :)
Какой подбор? Зачем?
Макрос делает в точности то, что написано в его описании, разве нет?

нет подбора

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  __  __   ____    _      __  __          _ 
| \/ | | _ \ | | \ \/ / _ _ (_)
| |\/| | | | | | | | \ / | | | | | |
| | | | | |_| | | |___ / \ | |_| | | |
|_| |_| |____/ |_____| /_/\_\ \__,_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.