Данный макрос позволяет получить список папок, расположенных в выбранной папке (каталоге)
Если надо получить список папок, имена которых удовлетворяют определённому критерию, используйте маску поиска (параметр 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
Комментарии
Спасибо за пример. Я писал такую программу на Си - там для каждого оператора dir(path) (findFirst(path)) создается свой контент и поэтому там сделать проще.
Здравствуйте! Не могли бы вы подсказать, я использую GetFolder для указанного пути, хочу получить объект с вложенными папками, но
их около 600. В итоге у меня получается объект в котором на счетчике указано Count = 600 , а самих item-ов ровно 256.
Листинг примерно такой:
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Путь)
Set fc = f.SubFolders
Здравствуйте
Да, могу
Оформляйте заказ на сайте, сделаем
Добрый день, а вы можете добавить в функцию FoldersCollection проверку в папках для найденных документов наличие в них картинок
Ринат, в статье ведь есть готовое решение: функция FoldersCollection
Добрый день всем!
Подскажите, пожалуйста, как в данный фрагмент кода вставить или как его изменить, чтобы он искал файлы не только в папке с рабочей книгой, но и в подпапках
Path = ThisWorkbook.Path
f = Dir(Path + "\\*_2015.xls")
Заранее спасибо!
Do While f <> ""
If Len(f) < 50 Then
Спасибо! Вопрос а как изменить код чтоб выводились все подпапки из требуемой папки?
Всё работает!!!!!!! Большущее спасибо!! Вы меня выручили уже второй раз!!!!!!!
После строки
добавьте строку
Здравствуйте! Ещё раз хочу поблагодарить за когда-то проделанную работу для меня (до сих пор пользуюсь и радуюсь) http://excelvba.ru/code/FoldersList.
И хотелось бы опять попросить о небольшом одолжении (так как в макросах не сильна). Мне вот этот бы макрос, под которым пишу комментарий) чуть чуть усовершенствовать. Что бы подпапки были ссылками на искомое место. Не прошу переделывать по новой, напишите какую строчку куда вставить. Заранее Благодарствую.
Выводить какие пути? К папкам или файлам? В каком виде?
Что означает фраза "общая папка всех подпапок"? Я не понимаю, о чем речь...
Добрый день.А если хочется что бы выводил пути из общей папки всех подпапок?
ошибся, все работает
А должен быть? :)
Какой подбор? Зачем?
Макрос делает в точности то, что написано в его описании, разве нет?
нет подбора
Отправить комментарий