Как получить список папок vba excel - Word и Excel - помощь в работе с программами

Получение списка папок 1, 2 и 3 уровней вложенности с помощью кода VBA Excel. SubFolders — коллекция подпапок, расположенных в указанной папке.

Свойство SubFolders объекта Folder

SubFolders — это свойство объекта Folder, которое возвращает коллекцию подпапок, расположенных в указанной папке (Folder), включая скрытые и системные папки.

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

Список папок 1 уровня вложенности

Получение списка папок 1 уровня вложенности:

Sub ShowFolderSublevel1()

Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, s As String

‘Указываем адрес исходной папки

s = «C:Users»

‘Создаем экземпляр FileSystemObject

Set fso = CreateObject(«Scripting.FileSystemObject»)

‘Присваиваем переменной fo ссылку на указанную папку

Set fo = fso.GetFolder(s)

‘Отключаем обработчик ошибок

On Error Resume Next

‘Обходим циклом коллекцию подпапок в указанной папке

For Each fo1 In fo.SubFolders

‘Печатаем полное имя текущей подпапки в окне Immediate

Debug.Print fo1 ‘.Path — по умолчанию

‘Включаем обработчик ошибок

On Error GoTo 0

End Sub

Если в исходной папке нет подпапок, то применение свойства SubFolders вызовет ошибку. Чтобы пропускать такие ошибки, мы отключаем обработчик ошибок на время работы циклов.

Список папок 2 уровня вложенности

Получение списка папок 1 и 2 уровней вложенности:

Sub ShowFolderSublevel2()

Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, fo2 As Folder, s As String

s = «C:Users»

Set fso = CreateObject(«Scripting.FileSystemObject»)

Set fo = fso.GetFolder(s)

On Error Resume Next

‘Обходим коллекцию подпапок 1 уровня вложенности

For Each fo1 In fo.SubFolders

Debug.Print fo1

‘Обходим коллекцию подпапок 2 уровня вложенности

For Each fo2 In fo1.SubFolders

‘Перед полным именем подпапки 2 уровня добавляем 4 пробела

Debug.Print Space(4) & fo2

On Error GoTo 0

End Sub

Список папок 3 уровня вложенности

Получение списка папок 1, 2 и 3 уровней вложенности:

Sub ShowFolderSublevel3()

Dim fso As FileSystemObject, fo As Folder, fo1 As Folder, fo2 As Folder, fo3 As Folder, s As String

s = «C:Users»

Set fso = CreateObject(«Scripting.FileSystemObject»)

Set fo = fso.GetFolder(s)

On Error Resume Next

‘Обходим коллекцию подпапок 1 уровня вложенности

For Each fo1 In fo.SubFolders

Debug.Print fo1

‘Обходим коллекцию подпапок 2 уровня вложенности

For Each fo2 In fo1.SubFolders

‘Перед полным именем подпапки 2 уровня добавляем 4 пробела

Debug.Print Space(4) & fo2

‘Обходим коллекцию подпапок 3 уровня вложенности

For Each fo3 In fo2.SubFolders

‘Перед полным именем подпапки 3 уровня добавляем 8 пробелов

Debug.Print Space(8) & fo3

On Error GoTo 0

End Sub

Обратите внимание, если вы будете использовать для тестов папку «C:Users» как исходную, все строки с наименованиями подпапок в окне Immediate не уместятся (ограничение — 200 строк).

Как получить список файлов в папке, смотрите в статье VBA Excel. Список файлов в папке.

Фразы для контекстного поиска: вложенная папка, вложенные папки, список подпапок, обход подпапок, вывод списка.

Источник

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

Добрый вечер.
Подскажите, пож-та, как с помощью кода VBA на лист Excel в столбец «А» получить список только папок (без файлов) в заданном каталоге. В именах папок могут встречаться точки и различные символы.
Заданный каталог к примеру c:1
Содержание заданного каталога может быть различным. Нужны только имена папок.

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

07.11.2020 20:29:45

Доброе время суток.
Например, так

Код

Public Sub ShowFolderList()
    Dim pDialog As FileDialog, pFolder As Object
    Dim fso As Object, nextFolder As Object
    Dim folderNames() As String, i As Long
    Set pDialog = Application.FileDialog(msoFileDialogFolderPicker)
    pDialog.AllowMultiSelect = False
    If pDialog.Show Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set pFolder = fso.GetFolder(pDialog.SelectedItems(1))
        ReDim folderNames(1 To pFolder.SubFolders.Count)
        i = 0
        For Each nextFolder In pFolder.SubFolders
            i = i + 1
            folderNames(i) = nextFolder.Name
        Next
        MsgBox Join(folderNames, vbLf)
    End If
End Sub

Изменено: Андрей VG — 07.11.2020 20:30:16

Dmitriy XM

Пользователь

Сообщений: 333
Регистрация: 06.03.2013

07.11.2020 20:47:55

Добрый день!

Код

Sub www()
Dim FSO As Object, fFolders As Object, fFolder As Object
Dim sFolderName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sFolderName = "D:Download"
Set fFolders = FSO.GetFolder(sFolderName)
For Each fFolder In fFolders.SubFolders
    x = x + 1
    Range("A" & x) = fFolder.Name
Next fFolder
End Sub

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

07.11.2020 20:51:42

Спасибо.
Есть ли возможность решить эту задачу по другому, без использования FSO ?
У меня получается вывести список файлов и папок, либо только файлов. А вот получить имена только папок не знаю как.
Вот фрагмент моего простенького кода. Может кто-то подправит?

Код
pathDis = "c:1" i = 1 J = 1 sPoisk = Dir(pathDis, vbDirectory) Do While sPoisk <> "" If (Len(Trim(Replace(sPoisk, ".", ""))) > 0) Then Range("A" & J) = sPoisk J = J + 1 End If sPoisk = Dir Loop

Изменено: asesja — 07.11.2020 20:53:44

БМВ

Модератор

Сообщений: 21383
Регистрация: 28.12.2016

Excel 2013, 2016

07.11.2020 21:33:55

Код

pathDis = "c:temp"
i = 1
J = 1
sPoisk = Dir(pathDis, vbDirectory)
Do While sPoisk <> ""
If (GetAttr(pathDis & sPoisk) And vbDirectory) = vbDirectory Then
    If (Len(Trim(Replace(sPoisk, ".", ""))) > 0) Then
        Range("A" & J) = sPoisk
        J = J + 1
    End If
End If
    sPoisk = Dir
Loop

Изменено: БМВ — 07.11.2020 21:42:15

По вопросам из тем форума, личку не читаю.

Андрей VG Пользователь Сообщений: 11878 Регистрация: 22.12.2012 Excel 2016, 365	Интересно, чем fso не угодил? Изменено: Андрей VG — 07.11.2020 21:42:14

asesja

Пользователь

Сообщений: 320
Регистрация: 21.10.2019

Всем огромное спасибо за помощь! Все предложенные варианты прекрасно работают.
Андрей, с FSO тоже все замечательно получилось. Просто хотел узнать как можно сделать по другому.
Забираю в копилку.

Изменено: asesja — 07.11.2020 21:54:25

у нас, на курсах трактористов, разрезали болгаркой жесткий диск
и переписывали вручную содержимое нужной папки
смело ложите в копилку 3-й способ

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

07.11.2020 23:10:19

Цитата
Ігор Гончаренко написал: …на курсах трактористов, разрезали болгаркой жесткий диск

Диск от колеса БелАЗа? )

Андрей VG

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#10

07.11.2020 23:49:59

Цитата
asesja написал: как можно сделать по другому

Можно ещё и так

Код

Public Sub ShowFolderList()
    Dim pDialog As FileDialog, pFolder As Object
    Dim pShell As Object, nextFolder As Object
    Dim pItems As Object
    Dim folderNames() As String, i As Long
    Set pDialog = Application.FileDialog(msoFileDialogFolderPicker)
    pDialog.AllowMultiSelect = False
    If pDialog.Show Then
        Set pShell = CreateObject("Shell.Application")
        Set pFolder = pShell.Namespace(pDialog.SelectedItems(1))
        Set pItems = pFolder.Items
        pItems.Filter 32, "*"
        ReDim folderNames(1 To pItems.Count)
        i = 0
        For Each pFolder In pItems
            i = i + 1
            folderNames(i) = pFolder.Name
        Next
        MsgBox Join(folderNames, vbLf)
    End If
End Sub

Объект Shell

Источник

Содержание

Получение списка подпапок из заданной папки по маске
Комментарии
VBA Excel. Список файлов в папке
Коллекция Files объекта Folder
Получение списка файлов в папке
Пример 1
Пример 2
18 комментариев для “VBA Excel. Список файлов в папке”
Получение списка файлов в папке и подпапках средствами VBA
Смотрите также расширенную версию макроса на базе этой функции:
Комментарии

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

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

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

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

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

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

Расширенная версия функции — для поиска подпапок любого уровня вложенности:

Здравствуйте! Не могли бы вы подсказать, я использую 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) #6

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

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

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

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

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

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

Источник

VBA Excel. Список файлов в папке

Получение списка файлов в указанной папке с помощью кода VBA Excel. Коллекция Files объекта Folder, возвращенного методом FileSystemObject.GetFolder.

Коллекция Files объекта Folder

Для получения списка файлов в указанной папке используется свойство Files объекта Folder . Объект Folder в VBA Excel возвращается методом GetFolder объекта FileSystemObject по полному имени папки в качестве аргумента.

Если в указанной папке нет файлов, применение свойства Folder.Files приведет к возникновению ошибки. Для корректного завершения программы используйте обработчик ошибок или условие, проверяющее наличие файлов в папке.

Получение списка файлов в папке

Пример 1

Код VBA Excel для получения списка файлов в указанной папке и записи полных имен файлов в массив (с поздней привязкой объектов к переменным):

fso – ссылка на экземпляр объекта FileSystemObject;
myPath – полное имя папки;
myFolder – ссылка на объект Folder (папка);
myFile – ссылка на один объект File из коллекции myFolder.Files;
myFiles() – массив для записи имен файлов;
i – счетчик элементов массива.

Пример 2

Получение списка файлов в указанной папке и запись имен файлов в ячейки первого столбца рабочего листа Excel (с ранней привязкой объектов к переменным):

Ранняя привязка позволяет использовать подсказки свойств и методов объектов при написании кода VBA Excel.

Как получить список папок до 3 уровней вложенности, смотрите в статье VBA Excel. Список папок.

Фразы для контекстного поиска: обход файлов.

18 комментариев для “VBA Excel. Список файлов в папке”

Здравствуйте!
Можно ли получить одно имя файла из списка коллекции Files используя свойство Folder.Files, при этом не используя цикл For Each?

Добрый день!
Одно имя получить можно, но только указав это самое имя, так как у коллекции Folder.Files есть только два свойства: Count и Item.

Item — свойство по умолчанию — его можно не указывать.

без явного указания имени в myFolder.Files.Item(«Зимняя картинка.doc»). Нужно получить имя файла не зная явно его имени. Попытка использования номера индекса myFolder.Files.Item(1) выдает ошибку.

Свойство Folder.Files.Item не работает с индексами. Скорее всего, за файлами в папке никакие индексы или номера по порядку не закреплены. По крайней мере те, которые может распознать .Item.

В итоге, существует ли способ получить одного имени файла из нескольких в папке, не используя запись в массив посредством цикла?

Dim myPath, myFolder As Folder, myFile As File, i
Где определяется что за пользовательский тип у Folder и File?

Добрый день, Сергей!
Это не пользовательские, а встроенные типы (классы) объектов, такие же, как, например, Worksheet или Range.

Забыли сказать, что необходимо подключить Scripting Runtime Library. Иначе код ругается на каждую переменную.
Если ее не подключать то необходимо для переменных myFile, myFolder и fso либо указать тип as Object либо не объявлять тип, тогда будет as Variant. И во втором примере сделать так:

Добрый день подскажите как сделать список файлов, если путь к ним прописать в ячейке A1?

Евгений добрый день, а не подскажите если такой макрос который применяет макрос к файлам в разных папках? Можно так чтоб указать начальную папку и он в подпапках искал нужные файлы и применял макрос или так например все пути файлов прописаны в столбце и применить макрос к данным файлам?

Добрый день, Юрий! Информация по вашему вопросу есть здесь.

Здравствуйте, как получить список я понимаю, а как к данному списку применить свой макрос, при том чтоб файлы открывались и закрывались сами?

Добрый день, Юрий!
Во втором примере из статьи замените блок

Добрый день, Евгений!
Есть вопрос!
На диске D имеется папка с названием Проба, в ней 10 файлов эксель.
Полученные файлы по почте, скидываются в папку Проба, при помощи копирование и вставить с заменой.
В файле эксель с названием Первый на Листе1 имеется таблица, в столбце А названия 10 файлов эксель.
Пожелание получить на Листе1 в таблице заливающуюся ячейку (или надпись «Обновлено»), после того как произведется вставка с заменой в папке Проба.
Это для того, чтобы было видно, какие файлы надо открыть, чтобы данные по ссылкам появились в файле Первый.
Подскажите?

Источник

Получение списка файлов в папке и подпапках средствами VBA

Функция FilenamesCollection предназначена для получения списка файлов из папки, с учётом выбранной глубины поиска в подпапках.

Используется рекурсивный перебор папок, до заданного уровня вложенности.
В процессе перебора папок, пути у найденным файлам помещаются в коллекцию (объект типа Collection) для последующего перебора.

К статье прикреплено 2 примера файла с макросами на основе этой функции:

Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки)
Пример в файле FilenamesCollectionEx.xls более функционален — он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.
Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)

Смотрите также расширенную версию макроса на базе этой функции:

Макрос FolderStructure выводит в таблицу Excel список файлов и подпапок с отображением структуры (вложенности файлов и подпапок)

ПРИМЕЧАНИЕ: Если вы выводите на лист список имен файлов картинок (изображений), то при помощи этой надстройки вы сможете вставить сами картинки в ячейки соседнего столбца (или в примечания к этим ячейкам)

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

Этот код позволяет осуществить поиск нужных файлов в выбранной папке (включая подпапки), и выводит полученный список файлов на лист книги Excel:

Ещё один пример использования:

PS: Найти подходящие имена файлов в коллекции можно при помощи следующей функции:

Не знаю что там за проблема с некорректными именами файлов, — я этот код использовал в сотнях макросов, эта функция работает в составе моих надстроек на десятках тысяч компьютеров, и никаких проблем не наблюдается.
И ни разу я не применял имена MS DOS..

Игорь, спасибо за рабочий пример (немного докрутил и использую в работе).
Что касается вопроса с некорректными именами файлов (которые не любит обрабатывать сей код (например, если в имени есть символ из непонятной кодировки)), выход нашел немного «топорный»: внутри обработки применяю имена MS DOS, которые обрабатываются нормально в большинстве случаев, а в интерфейсе делаю подмену имен на виндовые. Возможно не совсем понятно написал, но примера сейчас нет под рукой.

Спасибо автору, хороший код для поиска файлов, но возникает вопрос, а можно отключить отображение поиска внизу экселя?

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

Александр, нет таких полей у файлов произвольного формата, — потому, никак.

Посоветуйте пожалуйста как с помощью FSO получить доступ к полям Теги и Комментарии. Спасибо Alexander A. Rylov

Михаил, найдите в верхней части кода строку Option Explicit
и удалите её (эта строка требует объявлять переменные)

Подскажите. Почему excel может ругаться на
Set FSO = CreateObject(«Scripting.FileSystemObject») ‘ создаём экземпляр FileSystemObject
Пишет что переменная не объявлена/не определена

Нужно выше дописать
Dim FSO As Object?
Или в настройках excel 2016 что-то не так? Притом ругается на все не объявленные переменные.
А переменные типа Filename$ вообще не воспринимает как переменные. В чем может быть дело?
Гуглинг пока не помог.

Здравствуйте.
DoEvents никак не влияет на правильность работы (и не может повлиять)
А количество активных гиперссылок на листе Excel ограничено, — никак не сделать, чтобы на одном листе было более 50 или 65 тысяч АКТИВНЫХ гиперссылок.

Доброго времени суток. Огромное спасибо за программу!

Добавлю от себя и задам вопрос.

При использовании «DoEvents» программа может не правильно работать, в том числе выводить не все значения. Я ее закомментировал.

При привышении 65532 строк гиперссылки прекращают формироваться. Как можно победить?

Здравствуйте.
Под заказ что угодно могу сделать (платно)

Здравствуйте. Для примера из файла «FilenamesCollectionEx.xls» — можете сделать, чтобы выводимый на лист Excel список файлов был отсортирован по размеру(по уменьшению)?

Здравствуйте.
Могу сделать под заказ
Оформляйте заказ на сайте, и обязательно прикрепляйте пример файла с примером результата.

Здравствуйте! Меня тоже интересует макрос по поиску файлов. Можете сделать так что бы в ячейках к примеру A1 задать имя файла, A2 задать тип файла и A3 путь к папке?

Огромное Вам спасибо! Столько времени мне съэкономили.
СПА-СИ-БО! 🙂

Спасибо. Очень полезная вещь!

Здравствуйте, Юрий
Да, это можно исправить, — другой код нужен
(встроенные в VBA функции иногда дают ошибки)

Добрый день
В случае если в именах файлов встречаются нестандартные символы (допустимые в Win) макрос выдает ошибку
Ошибка в строке ДатаСоздания = FileDateTime(ПутьКФайлу)
Можно добавить onError Resume Next но это пропуск ошибки будет а размер файла не будет определен. Есть ли варианты сделать определение размера файлов и для таких файлов тоже?

Пример папки на которой сканирование папки «спотыкается»: https://bit.ly/2zz8Tfw

Игорь, подскажите, а можно ли в файл FilenamesCollectionEx.xls добавить маску имени подпапки, в которой производить поиск? Ситуация: файл с одинаковм именем может лежать в подпапках с разными именами. Я точно знаю, что нужная мне версия должна лежать в определенной подпапке. И проверять таким образом только их?

Так вроде и то и другое выводится
Код открыт ведь, — поменяйте как вам надо, если лишний столбец мешает.

Возможно я слепой или плохо читаю, но я не увидел что-то подобное в коментах. Поэтому мой вопрос следующий: можно как-то сделать так, чтобы выводило только название файла а не весь путь?

Отбой, разобрался. Виноват оказался не этот макрос, а тот, который его результаты использовал. Мораль — люди, не юзайте Dir, если вам нужно что-то сделать с папкой, к которой он обращается.

В моём макросе нет MoveFolder — так что мой макрос точно не виноват в вашей проблеме.
Проблема — либо в неверном использовании MoveFolder (не то или не туда перемещаете), либо нет прав доступа на перемещение в заданное место.

Игорь, всё это прекрасно. Непонятно только, что нужно сделать с Вашим макросом, чтобы после его вызова с папкой можно было бы ещё и что-нибудь сделать, например, переместить. Сейчас после вызова FSO.MoveFolder вылетает с ошибкой Access denied. Проверено, виноват именно Ваш макрос — если закомментировать ТОЛЬКО его вызов, FSO.MoveFolder отрабатывает нормально.

Спасибо, ОГРОМНОЕ.
Выручайте ребята! макрос в целом отличный, но для моих целе нужно немного переделать.
Нужно чтоб все файлы находящиеся в каждой папке были в одной ячейке через разделитель ( | )
Например:
C:images4-20161032g.jpg|C:images4-20161033g.jpg|C:images4-20161033g.jpg

Да, сделал.
Высылайте на почту подробное задание (что и как должно выглядеть, для чего это вообще нужно, и т.д.)
Тогда озвучу сроки и стоимость

Добрый день!
Скажите, пожалуйста, сделали ли вы макрос для Александра?
Если да, то за сколько его можно приобрести?
Если нет, то какие сроки выполнения?
Спасибо!

Напишите на почту стоимость и сроки выполнения

Александр, в этом случае нужен более сложный макрос.
Могу сделать под заказ.

Здравствуйте, Макрос хороший. Всё отлично выводит. Но как сделать дерево? Имеется несколько папок, далее нажимаешь на папку или плюс или еще что-то, она открывается, появляется подпапки, опять жмешь на подпапку появляются подпапки и т.д.

Спасибо, отличный макрос

В ответ на:
Андрей, 15 Мар 2018 — 15:13.#3
Добрый день.
файл 148 знаков (рус.буквы) не обрабатывается,
и сам файл на сервере (если файл на раб.столе то все работает)
какая максимальная длина имени и можно-ли ее обойти.

Ограничение на полное имя файла, включая расширение — 259 символов. Соответственно, все файлы, имеющие более длинное имя при выполнении
Set curfold = FSO.GetFolder(FolderPath)
будут проигнорированы. Тестировал на EX2010, W7 и MSServer 2008. У меня из 28 (curfold.Соunt) файлов реально в коллекции только 15 (curfold.items(1). curfold.items(15))

А как сделать макрос чтобы он мне показал только пустые папки?

Ограничений по длине имени файла, вроде как, нет (по крайней мере, за много лет использования этого кода на тысячах компов, с проблемами не сталкивался)

Добрый день.
файл 148 знаков (рус.буквы) не обрабатывается,
и сам файл на сервере (если файл на раб.столе то все работает)
какая максимальная длина имени и можно-ли ее обойти.

Адаптировал к access — все работает, спасибо, очень помогло

Ринат, посмотрите макрос обработки файлов из папки.
Там выводится диалоговое окно папки, и обрабатываются все файлы в ней (независимо от имён файлов)

Добрый день!
Такой вопрос, в отделе каждый месяц сотрудник ведет отчет по своей работе в табличной форме в ексель каждый в своем файле, а начальству необходимо данные отчеты ввести в свою итоговую таблицу для себя, то есть скопировать данные отчетов с файлов каждого сотрудника в свой отдельный файл. Я создал макрос, для скопирования данных с файлов каждого сотрудника в таблицу файла начальству указывая путь к каждому файлу. Но при этом возникает определенные неудобства, каждый месяц нужно пути к файлам прописывать заново, так как на следующий месяц создаются новые файлы по отчетам, и пути к ним необходимо обновлять. Подскажите пожалуйста, как можно сделать так, чтоб пути к файлам привязывались не по конкретному расположению файла, а например указыванием месяца и года можно было сформировать единый отчет на определенный месяц. Спасибо заранее!

Большое спасибо автору! Список использую для каталогизации архива сканов документов.

Да, можем сделать такой макрос под заказ.
Минимальная стоимость заказа 1500 руб.

добрый день
подскажите можно ли написать макрос под следующие цели
необходимо что бы в ячеке которую выделил вписывались имена файлов фотографий, если их несколько выбираешь тогда добавляются все через запятую или точку запятую только имя файла и расширение
например как вставить фото в ячейку но вставляется не фото а именно имя

или например на основе Вашего FilenamesCollectionEx.xls нашел все файлы на диске/папке нужные -нажимаешь на файл и ты нужен выбрать ячейку куда вписать имя файла
заранее спасибо

У меня почему-то размер файла в байтах выводится абсолютно иной, иногда даже с отрицательным значением.
Пример:
1.вес файла 3 840 327 Кб или 3,66 Гб, а таблица выдает «-362 472 675»
2.вес файла 5 082 087 Кб или 4,84 Гб, таблица выдает «909 089 137»

Василий, да, можно добавить.
Пример код можете здесь посмотреть:
http://excelvba.ru/code/MCI

Добрый день! Подскажите, возможно ли добавить столбцы «продолжительность» и «ширина кадра», которые имеются в данных файлов?

Здравствуйте, Елизавета.
Причин может быть несколько, навскидку:
— проблемный файл, или файл, к которому у вас нет доступа (ошибка 53 — файл не найден)
— слишком длинное имя папки (много уровней вложенности) и/или файла
— сбой в файловой системе
— ошибка в макросе (что-то в коде не учтено)

Техподдержка по бесплатным макросам не предоставляется
Если готовы оплатить помощь, — звоните в скайп, могу подключиться к вашему компу и всё исправить.

Игорь, огромное вам спасибо за эту работу!
Несколько лет использую ваш файл для классификации фильмов, но пару недель назад почему-то он перестал работать. Никакой критичности в этом нет, т.к. главное исправила благодаря обсуждениям тут, но мне непонятно и жутко интересно, почему так происходит. Может, это связано с активацией офиса(примерно в то же время было)? Офис 10й.
У меня 2 вкладки в этом файле, обновляю список на 2й, и затем новые позиции копирую в первую (накапливаю). При обновлении списка, после 60-70 позиций, макрос останавливается и сообщает об ошибке Run-time error 53 со сслыкой на строку ДатаСоздания = FileDateTime(ПутьКФайлу). Дело не файле, т.к. его удаление не помогло. Я добавила в скрипт «On Error Resume Next», список обновляется до конца, но перестают запускаться фильмы по гиперссылке в 1й вкладке «не удается открыть указанный файл» (во 2й работают), хотя файл и макросы одни и те же. Знаете, в чем может быть причина?

Источник

А что бы в список попали всякие с причудами директории, можно написать так —

Visual Basic

D = Dir(path, vbDirectory Or vbHidden Or vbSystem)
While D <> ""
  If GetAttr(path & "" & D) And vbDirectory And D <> "."  And D <> ".." Then
  'далее по тексту

Упсс: Это была добавка к четвёртому посту.

Добавлено через 31 минуту

Сообщение от Diskretor

Эту строку ‘If GetAttr(path & «» & D) And vbDirectory Then’ я, конечно, подсмотрел на MSDN, но нифига не понял зачем там ‘vbDirectory).
…она все равно выводит в т.ч. имена файлов.

На уровне подсознания я понимаю эту фишку, но сомневаюсь, сумею ли внятно объяснить
Но попробую-

Сообщение от F1

Dir[(pathname[, attributes])]
The attributes argument settings are:
Constant Value Description
vbNormal 0 (Default) Specifies files with no attributes.
vbReadOnly 1 Specifies read-only files in addition to files with no attributes.
vbHidden 2 Specifies hidden files in addition to files with no attributes.
VbSystem 4 Specifies system files in addition to files with no attributes
vbVolume 8 Specifies volume label; if any other attributed is specified, vbVolume is ignored
vbDirectory 16 Specifies directories or folders in addition to files with no attributes.

Dir ищет по сумме аттрибутов, поэтому 0 (vbNormal) на него не влияет, что бы ни указали в параметре attributes, поэтому и попадают в результат обычные (vbNormal) файлы.
А потому и необходима дополнительная фильтрация… Вот(уж как сумел)

Добавлено через 21 минуту
То есть

Visual Basic

1	Dir(path, vbDirectory Or vbNormal)

Visual Basic

1	Dir(path, vbDirectory)

одно и тоже, с точки зрения Dir!

Добавлено через 6 минут

Сообщение от Diskretor

И еще вопрос: написано, что нужно ставить двойные кавычки Chr(34), если в имени папки есть пробелы. Но у меня все работает и без них. И наоборот ничего не выдает/работает неверно, если их указать.

Тоже с этим сталкивался неоднократно
Сделал вывод — для Dir это не нужно,
а для Shell и т.п. необходимо…

Источник

Вы когда-нибудь сталкивались с этой проблемой, когда перечисляли все папки и подпапки из указанного каталога на листе? В Excel нет быстрого и удобного способа получить имена всех папок в определенном каталоге сразу. Разобраться с этой задачей может вам эта статья.

Список всех папок и подпапок с кодом VBA

Список всех папок и подпапок с кодом VBA

Если вы хотите получить все имена папок из указанного каталога, следующий код VBA может вам помочь, сделайте следующее:

1. Удерживайте ALT + F11 ключи, и он открывает Окно Microsoft Visual Basic для приложений.

2. Нажмите Вставить > Модулии вставьте следующий код в Окно модуля.

Код VBA: список всех папок и имен вложенных папок

Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & ""
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
    xRow = Range("A1").End(xlDown).Row + 1
    Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
    getSubFolder subfld
Next subfld
End Sub

3, Затем нажмите F5 ключ для запуска этого кода и Выбрать папку появится всплывающее окно, затем вам нужно выбрать каталог, в котором вы хотите отобразить имена папок и подпапок, см. снимок экрана:

4. Нажмите OK, и вы получите путь к папке и подпапкам, каталог, имя, дату создания и дату последнего изменения в новой книге, см. снимок экрана:

Связанная статья:

Как перечислить файлы в каталоге на лист в Excel?

Лучшие инструменты для работы в офисе

Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%

Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма …
Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон…
Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы… Предотвращение дублирования ячеек; Сравнить диапазоны…
Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор …
Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое …
Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии…
Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом …
Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF…
Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!

Комментарии (18)

Оценок пока нет. Оцените первым!

Источник

Файлы к уроку:

Для спонсоров Boosty
Для спонсоров VK

YouTube
VK

Описание

Создадим макросы, которые выводят на листах Excel списки всех файлов в папке, папок и файлов внутри папок.

Решение

Список всех файлов внутри папки

' Перечень файлов внутри папки
Sub get_file_names()

    Dim objFSO As Object        ' В этой переменной будет объект FileSystemObject
    Dim objFolder As Object     ' В этой переменной будет объект Folder
    
    ' Получаем доступ к файловой системе компьютера
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    ' Создаем объект Folder
    Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
    
    ' Строка для вывода
    row = 2
    
    ' Цикл по каждому файлу в папке
    For Each file In objFolder.Files
        ' Имя файла
        Cells(row, 1) = file.Name
        ' Путь к папке
        Cells(row, 2) = objFolder
        ' Переход на следующую строку
        row = row + 1
    Next file
    
    ' Автоподбор ширины
    Columns("A").EntireColumn.AutoFit

End Sub

Список всех папок внутри папки

' Перечень папок внутри папки
Sub get_subfolder_names()

    Dim objFSO As Object
    Dim objFolder As Object
    
    ' Получаем доступ к файловой системе компьютера
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    ' Создаем объект Folder
    Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
    
    ' Строка для вывода
    row = 2
    
    ' Цикл по каждой папке в папке
    For Each folder In objFolder.subfolders
        ' Вывод имени файла
        Cells(row, 1) = folder.Name
        ' Путь к папке
        Cells(row, 2) = folder.Path
        ' Переход на следующую строку
        row = row + 1
    Next folder
    
    ' Автоподбор ширины
    Columns("A").EntireColumn.AutoFit
    
End Sub

Список всех файлов в папке, папок и файлов внутри папок

' Перечень папок и файлов внутри них
Sub get_subfolder_and_file_names()

    Dim objFSO As Object
    Dim objFolder As Object
    
    ' Получаем доступ к файловой системе компьютера
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    ' Создаем объект Folder
    Set objFolder = objFSO.GetFolder("c:Userstimur.kryukovDownloadscomrade.excel ideasVBA. Практика. Список всех файлов в папкеDirectory")
    
    ' Строка для вывода
    row = 2
    
    ' Цикл по каждой папке
    For Each subfolder In objFolder.subfolders
        ' Цикл по каждому файлу
        For Each file In subfolder.Files
            ' Имя папки
            Cells(row, 1) = subfolder.Name
            ' Имя файла
            Cells(row, 2) = file.Name
            ' Путь к файлу/папке
            Cells(row, 3) = file.Path
            ' Переход на следующую строчку
            row = row + 1
        Next file
    Next subfolder
    
    For Each file In objFolder.Files
        ' Имя папки
        Cells(row, 1) = objFolder.Name
        ' Имя файла
        Cells(row, 2) = file.Name
        ' Путь к файлу
        Cells(row, 3) = file.Path
        ' Переход на следующую строчку
        row = row + 1
    Next file
    
End Sub

Примененные функции

.GetFolder
Cells
CreateObject
For Each
Scripting.FileSystemObject

Источник

Updated July 2014: Added PowerShell option and cut back the second code to list folders only

The methods below that run a full recursive process in place of FileSearch which was deprecated in Office 2007. (The later two codes use Excel for output only — this output can be removed for running in Word)

Shell PowerShell
Using FSO with Dir for filtering file type. Sourced from this EE answer which sits behind the EE paywall. This is longer than what you asked for (a list of folders) but i think it is useful as it gives you an array of results to work further with
Using Dir. This example comes from my answer I supplied on another site

1. Using PowerShell to dump all folders below C:temp into a csv file

Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:tempfilename.csv", 1)
End Sub

2. Using FileScriptingObject to dump all folders below C:temp into Excel

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:temp"
myArr = GetSubFolders(strPath)
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)
End Sub


Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
    ReDim Preserve Arr(Counter)
    Arr(Counter) = sf.Path
    Counter = Counter + 1
    myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function

3 Using Dir

    Option Explicit

    Public StrArray()
    Public lngCnt As Long
    Public b_OS_XP As Boolean

    Public Enum MP3Tags
    '  See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists
    XP_Artist = 16
    XP_AlbumTitle = 17
    XP_SongTitle = 10
    XP_TrackNumber = 19
    XP_RecordingYear = 18
    XP_Genre = 20
    XP_Duration = 21
    XP_BitRate = 22
    Vista_W7_Artist = 13
    Vista_W7_AlbumTitle = 14
    Vista_W7_SongTitle = 21
    Vista_W7_TrackNumber = 26
    Vista_W7_RecordingYear = 15
    Vista_W7_Genre = 16
    Vista_W7_Duration = 17
    Vista_W7_BitRate = 28
    End Enum

    Public Sub Main()
    Dim objws
    Dim objWMIService
    Dim colOperatingSystems
    Dim objOperatingSystem
    Dim objFSO
    Dim objFolder
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim strobjFolderPath As String
    Dim strOS As String
    Dim strMyDoc As String
    Dim strComputer As String

   'Setup Application for the user
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With    

    'reset public variables
    lngCnt = 0
    ReDim StrArray(1 To 10, 1 To 1000)

    ' Use wscript to automatically locate the My Documents directory
    Set objws = CreateObject("wscript.shell")
    strMyDoc = objws.SpecialFolders("MyDocuments")


    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\" & strComputer & "rootcimv2")
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOperatingSystem In colOperatingSystems
        strOS = objOperatingSystem.Caption
    Next

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If InStr(strOS, "XP") Then
        b_OS_XP = True
    Else
        b_OS_XP = False
    End If


    ' Format output sheet
    Set Wb = Workbooks.Add(1)
    Set ws = Wb.Worksheets(1)
    ws.[a1] = Now()
    ws.[a2] = strOS
    ws.[a3] = strMyDoc
    ws.[a1:a3].HorizontalAlignment = xlLeft

    ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate")
    ws.Range([a1], [j4]).Font.Bold = True
    ws.Rows(5).Select
    ActiveWindow.FreezePanes = True


    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(strMyDoc)

    ' Start the code to gather the files
    ShowSubFolders objFolder, True
    ShowSubFolders objFolder, False

    If lngCnt > 0 Then
        ' Finalise output
        With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10))
            .Value2 = Application.Transpose(StrArray)
            .Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter
            .Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit
        End With
        ws.[a1].Activate
    Else
        MsgBox "No files found!", vbCritical
        Wb.Close False
    End If

    ' tidy up

    Set objFSO = Nothing
    Set objws = Nothing

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = vbNullString
    End With
    End Sub

    Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)
    Dim objShell
    Dim objShellFolder
    Dim objShellFolderItem
    Dim colFolders
    Dim objSubfolder


    'strName must be a variant, as ParseName does not work with a string argument
    Dim strFname
    Set objShell = CreateObject("Shell.Application")
    Set colFolders = objFolder.SubFolders
    Application.StatusBar = "Processing " & objFolder.Path

    If bRootFolder Then
        Set objSubfolder = objFolder
        GoTo OneTimeRoot
    End If

    For Each objSubfolder In colFolders
        'check to see if root directory files are to be processed
    OneTimeRoot:
        strFname = Dir(objSubfolder.Path & "*.mp3")
        Set objShellFolder = objShell.Namespace(objSubfolder.Path)
        Do While Len(strFname) > 0
            lngCnt = lngCnt + 1
            If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))
            Set objShellFolderItem = objShellFolder.ParseName(strFname)
            StrArray(1, lngCnt) = objSubfolder
            StrArray(2, lngCnt) = strFname
            If b_OS_XP Then
                StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist)
                StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle)
                StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle)
                StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber)
                StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear)
                StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre)
                StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration)
                StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate)
            Else
                StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist)
                StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle)
                StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle)
                StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber)
                StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear)
                StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre)
                StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration)
                StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate)
            End If
            strFname = Dir
        Loop
        If bRootFolder Then
            bRootFolder = False
            Exit Sub
        End If
        ShowSubFolders objSubfolder, False
    Next
    End Sub

Источник

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

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

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

Источник

Свойство SubFolders объекта Folder

Список папок 1 уровня вложенности

Список папок 2 уровня вложенности

Список папок 3 уровня вложенности

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

Комментарии

VBA Excel. Список файлов в папке

Коллекция Files объекта Folder

Получение списка файлов в папке

Пример 1

Пример 2

18 комментариев для “VBA Excel. Список файлов в папке”

Получение списка файлов в папке и подпапках средствами VBA

Смотрите также расширенную версию макроса на базе этой функции:

Комментарии

Лучшие инструменты для работы в офисе

Kutools for Excel Решит большинство ваших проблем и повысит вашу производительность на 80%

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

Описание

Решение

Список всех файлов внутри папки

Список всех папок внутри папки

Список всех файлов в папке, папок и файлов внутри папок

Примененные функции

А вот еще интересные статьи: