Функция 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
Этот код позволяет осуществить поиск нужных файлов в выбранной папке (включая подпапки), и выводит полученный список файлов на лист книги 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
Комментарии
Здравствуйте, Марина.
Конечно можно. Загружаете файл XML с сайта, и анализируете его содержимое.
Весь необходимый код можно найти у меня на сайте.
Добрый день!
А можно как-то сделать так, чтобы список файлов извлекался из xml-каталога, размещенного на веб-странице?
fil - это переменная. Как именно она называется - не столь важно, лишь бы имя не совпадало с зарезервированными служебными именами.
Можно заменить на f или fl или file_, или el...
Перевод
For Each fil In curfold.Files
звучит так:
для каждого fil из файлов curfold
fil и curfold - это имена переменных, могут быть такими, какие Вы им дадите.
Ясно, жаль, просто хотелось именно понять, а не просто копи-пастить. В любом случае - спасибо за отличный пример)
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)
Спасибо Вам огромное!
Здравствуйте, Андрей.
Да, можно добавить и дату создания, и дату изменения файла, и дату последнего обращения к файлу.
Внесите коррективы в код макроса записи данных на лист:
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 из указанной папки, причем если напротив названия файла стоит "н", то в итоговый файл он не включается, если вам интересно, посмотрите http://www.fayloobmennik.net/1343362
Можно и так сделать. Только код потребует заметной переделки.
Если готовы оплатить работу - оформляйте заказ, сделаю.
а если в корневой папке лежат подпапки, в которых тоже могут лежать подпапки и фай файлы и нужно вывести названия независимо, файл это или папка в одной колонке?
вот пример http://www.fayloobmennik.net/1339101
Ваше желание выполнено. Проверяйте: макрос вывода списка подпапок 2 уровней вложенности
<здесь была ссылка на файлообменник с примером файла>
вот если сделаете, то будет очень здорово!Буду очень благодарна!
Я бы вам помог адаптировать макрос, но только если вы подготовите пример результата (как он должен выглядеть: заголовок таблицы + 2-3 заполненные строки).
Очень уж не люблю переделывать макросы, когда выясняется, что надо было "не совсем так"...
Пробовала, нашла и этот макрос, тоже замечательный, взяла в копилку (огромное спасибо за труды), просто вот как раз надо было бы мне чтобы выводился и второй уровень, т.е. какие подпапки есть в тех папках.(Пример: есть 400 авторов у каждого 10-40 произведений, так вот бы вывести 400 авторов папок и у каждого что бы видно было какие произведения подпапки у него есть, а уж что в самих подпапках уже не интересует)
А поискать готовый макрос у меня на сайте не пробовали?
http://excelvba.ru/code/SubFoldersCollection
Отличная вещица получилась!!!! Просто незаменимая и главное удобная.
У меня только вопрос, а если мне надо не файлы вывести, а в папке список подпапок, такое реально? Допустим есть папки Писатели, в каждой папке есть подпапки с Книгами в них лежат Страницы и Иллюстрации, но страницы и иллюстрации меня не интересуют, надо чтобы видно было Писателей и какие у них Книги (желательно с размером папки) ;)
В данном примере это реально сделать или это применимо только для файлов????
не совсем, нужно, чтоб название папки было в той же колонке, что и название файлов, в которой они находятся, то есть располагалось над вложенными в нее файлами
Так нужно было?
Проверяйте макрос с изменениями
Внёс изменения в код:
Подпапка$ = 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 не работает :( А очень нужно!
СУПЕР
Спасибо, очень познавательно
Просто супер!
Очень полезные функции спасибо автору
Спасибо за полезную информацию
Отправить комментарий