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

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

Макрос VBA загрузки списка файлов из папки

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

 

Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки) 

Пример в файле FilenamesCollectionEx.xls более функционален - он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.

Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)

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

Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .txt, но и .TXT и .Txt),
поставьте первой строкой в модуле директиву Option Compare Text

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function


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

Sub ОбработкаФайловИзПапки()
    On Error Resume Next
    Dim folder$, coll As Collection
 
    folder$ = ThisWorkbook.Path & "\Платежи\"
    If Dir(folder$, vbDirectory) = "" Then
        MsgBox "Не найдена папка «" & folder$ & "»", vbCritical, "Нет папки ПЛАТЕЖИ"
        Exit Sub        ' выход, если папка не найдена
    End If
 
    Set coll = FilenamesCollection(folder$, "*.xls")        ' получаем список файлов XLS из папки
    If coll.Count = 0 Then
        MsgBox "В папке «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» нет ни одного подходящего файла!", _
               vbCritical, "Файлы для обработки не найдены"
        Exit Sub        ' выход, если нет файлов
    End If
 
    ' перебираем все найденные файлы
    For Each file In coll
        Debug.Print file        ' выводим имя файла в окно Immediate
    Next
End Sub


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

Sub ПримерИспользованияФункции_FilenamesCollection()
    ' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён.
    ' Просматриваются папки с глубиной вложения не более трёх.

    Dim coll As Collection, ПутьКПапке As String
    ' получаем путь к папке РАБОЧИЙ СТОЛ
    ПутьКПапке = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке, ".txt", 3)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана
    ' создаём новую книгу
    Dim sh As Worksheet: Set sh = Workbooks.Add.Worksheets(1)
    ' формируем заголовки таблицы
    With sh.Range("a1").Resize(, 3)
        .Value = Array("№", "Имя файла", "Полный путь")
        .Font.Bold = True: .Interior.ColorIndex = 17
    End With
 
    ' выводим результаты на лист
    For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам
        sh.Range("a" & sh.Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = _
        Array(i, Dir(coll(i)), coll(i))    ' выводим на лист очередную строку
        DoEvents    ' временно передаём управление ОС
    Next
    sh.Range("a:c").EntireColumn.AutoFit    ' автоподбор ширины столбцов
    [a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
End Sub

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

Sub ЗагрузкаСпискаФайлов()
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%
 
    ПутьКПапке$ = [c1]    ' берём из ячейки c1
    МаскаПоиска$ = [c2]    ' берём из ячейки c2
    ГлубинаПоиска% = Val([c3])    ' берём из ячейки c3
    If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)
 
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        НомерФайла = i
        ПутьКФайлу = coll(i)
        ИмяФайла = Dir(ПутьКФайлу)
        ДатаСоздания = FileDateTime(ПутьКФайлу)
        РазмерФайла = FileLen(ПутьКФайлу)
 
        ' выводим на лист очередную строку
        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(НомерФайла, ИмяФайла, ПутьКФайлу, ДатаСоздания, РазмерФайла)
 
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
                                   "Открыть файл" & vbNewLine & ИмяФайла
 
        DoEvents    ' временно передаём управление ОС
    Next
End Sub

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

Function CollectionAutofilter(ByRef coll As Collection, ByVal filter$) As Collection
    ' Функция перебирает все элементы коллекции coll,
    ' оставляя лишь те, которые соответствуют маске filter$ (например, filter$="*некий текст*")
    ' Возвращает коллекцию, содержащую только подходящие элементы
    ' Если элементы не найдены - возвращается пустая коллекция (содержащая 0 элементов)
    On Error Resume Next: Set CollectionAutofilter = New Collection
    For Each Item In coll
        If Item Like filter$ Then CollectionAutofilter.Add Item
    Next
End Function

ВложениеРазмерЗагрузкиПоследняя загрузка
FilenamesCollection.xls35 КБ81215 часов 52 минуты назад
FilenamesCollectionEx.xls56 КБ763615 часов 10 минут назад

Комментарии

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

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

Ясно, жаль, просто хотелось именно понять, а не просто копи-пастить. В любом случае - спасибо за отличный пример)

WorkBook.close() не?

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

Здравствуйте! Я чего-то не понимаю,
"For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path"
fil - это очепятка или ...?
Спасибо!

Да, вы правы! :)
Привык работать с Option Explicit...

Здравствуйте, Владимир.

Это нужно, если вы используете директиву Option Explicit в своих макросах
(обратите внимание на самую верхнюю строку в модуле)

Именно директива Option Explicit требует от вас явно указывать тип всех переменных.

Я в своих макросах эту директиву не использую, поэтому могу позволить себе не объявлять некоторые переменные
(ибо знаю, как их следует использовать, и не ошибаюсь в их названиях)

Если вы обратили внимание, в прикреплённых файлах всё работает и без принудительного объявления переменных.

Следовательно, добавлять что-либо в код нет необходимости.

Перед Set FSO = CreateObject("Scripting.FileSystemObject") нужно добавить Dim FSO As Object
И в других местах - также

Здравствуйте, вопрос такого плана. Отчет выводится в файл типа .xls (используется подготовленный шаблон .xlt), имя файла формируется программно и сохраняется отчет в определенную папку, при выполнении отчета - файл открывается. Естественно при повторном создании этого же отчета файл не сохранятеся, т.к. он открыт. Вопрос: как закрыть открытый файл xls программно? (access 2003)

Спасибо Вам огромное!

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

Внесите коррективы в код макроса записи данных на лист:

    ' ДОБАВЬТЕ ЭТУ СТРОКУ ПЕРЕД ЦИКЛОМ ' создаём экземпляр FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам
        ' ...
        ДатаСоздания = fso.GetFile(ПутьКФайлу).DateCreated
        ДатаПоследнегоИзменения = fso.GetFile(ПутьКФайлу).DateLastModified
        ДатаПоследнегоОбращенияКФайлу = fso.GetFile(ПутьКФайлу).DateLastAccessed
        ' ...
    Next

Очень полезная вещь!
Один вопрос, возможно ли добавить "дату создания"? (не дату последнего сохранения, как сделано сейчас)

Шикарная штучка!
Искал давно, но...
Возможно ли в макрос добавить столбцы, такие как "Дата создания" "Дата посл. сохр." "Дата печати" и другие. Если да, то как (совет, готовый макрос)? За второй вариант, готов поделиться некоторой (реальной) суммой.

очень полезный кодик! не ожидал что найду что искал! спасибо!

Извините, Вика, но не смогу подсказать.
С Access я ни разу не работал - так что не знаю даже, как на них выводить информацию.

Главное, что у вас есть готовый код для получения коллекции с именами файлов.
Спросите на любом форуме по Access, как вывести на форму элементы коллекции, - и всё у вас получится.

Не могли бы вы подсказать как переделать данный файл для работы под форму access?

Кстати, есть функция, которая собирает Pdf по списку файлов из Excel из указанной папки, причем если напротив названия файла стоит "н", то в итоговый файл он не включается

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

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

<здесь была ссылка на файлообменник с примером файла>
вот если сделаете, то будет очень здорово!Буду очень благодарна!

Я бы вам помог адаптировать макрос, но только если вы подготовите пример результата (как он должен выглядеть: заголовок таблицы + 2-3 заполненные строки).
Очень уж не люблю переделывать макросы, когда выясняется, что надо было "не совсем так"...

Пробовала, нашла и этот макрос, тоже замечательный, взяла в копилку (огромное спасибо за труды), просто вот как раз надо было бы мне чтобы выводился и второй уровень, т.е. какие подпапки есть в тех папках.(Пример: есть 400 авторов у каждого 10-40 произведений, так вот бы вывести 400 авторов папок и у каждого что бы видно было какие произведения подпапки у него есть, а уж что в самих подпапках уже не интересует)

А поискать готовый макрос у меня на сайте не пробовали?
http://excelvba.ru/code/SubFoldersCollection

Отличная вещица получилась!!!! Просто незаменимая и главное удобная.
У меня только вопрос, а если мне надо не файлы вывести, а в папке список подпапок, такое реально? Допустим есть папки Писатели, в каждой папке есть подпапки с Книгами в них лежат Страницы и Иллюстрации, но страницы и иллюстрации меня не интересуют, надо чтобы видно было Писателей и какие у них Книги (желательно с размером папки) ;)
В данном примере это реально сделать или это применимо только для файлов????

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

Так нужно было?

Проверяйте макрос с изменениями

Внёс изменения в код:

        Подпапка$ = Left(ПутьКФайлу, Len(ПутьКФайлу) - Len(ИмяФайла))
        Подпапка$ = Replace(Подпапка$, ПутьКПапке$, "")
 
        ' выводим на лист очередную строку
        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(НомерФайла, Подпапка$, ИмяФайла, ДатаСоздания, РазмерФайла)
 
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("c" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
                                   "Открыть файл" & vbNewLine & ИмяФайла

Уточняю, что сделать, чтобы в файле FilenamesCollectionEx.xls в столбце В перед списком имен файлов выводилось бы название подпапки?

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

Поскольку вы не удосужились уточнить, в какой из 2 примеров, и в какой столбец в каком виде выводить название папки, - на примере показать не смогу.

Здорово! Очень полезно и актуально! А не скажете ли вы, как сделать, чтобы названия папок тоже бы выводились в список?

Отлично! Просто и изящно. Небольшое замечание:
Для того, чтобы поиск по маске происходил независимо от регистра символов в имени файла, нужно в начале модуля задать способ сравнения оператора Like:

Option Compare Text

Спасибо, то что нужно!

Улетное решение! При переходе с 2003 на 2010 встал вопрос замены для объекта FileSearch - вопрос теперь решен! Автору - спасибо!
Одна доработка все-таки имела место: чтобы искать ТОЧНО по маске, нужно было убрать в процедуре наполнения коллекции звездочку - ' Like "*" & Mask' ... т.е. получилось ' Like Mask ' ....

Используя Ваш код оформил все это дело в виде UserForm, поместил в свою надстройку.
Добавил немного универсальности.
Неплохо вроде получилось.
Хотелось бы показать Вам, как автору кода, да не знаю как прикрепить файл или куда выслать.

Отлично!
Как раз пригодилось.
Спасибо.

Автору признательность и почтение!

Супер! Но есть одно НО: на MAC OS не работает :( А очень нужно!

СУПЕР

Спасибо, очень познавательно

Просто супер!

Очень полезные функции спасибо автору

Спасибо за полезную информацию

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

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

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

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