Функция FilenamesCollection предназначена для получения списка файлов из папки, с учётом выбранной глубины поиска в подпапках.
Используется рекурсивный перебор папок, до заданного уровня вложенности.
В процессе перебора папок, пути у найденным файлам помещаются в коллекцию (объект типа Collection) для последующего перебора.
К статье прикреплено 2 примера файла с макросами на основе этой функции:
- Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки)
- Пример в файле FilenamesCollectionEx.xls более функционален - он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.
Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)
Смотрите также расширенную версию макроса на базе этой функции:
Макрос FolderStructure выводит в таблицу Excel список файлов и подпапок с отображением структуры (вложенности файлов и подпапок)
ПРИМЕЧАНИЕ: Если вы выводите на лист список имен файлов картинок (изображений), то при помощи этой надстройки вы сможете вставить сами картинки в ячейки соседнего столбца (или в примечания к этим ячейкам)
Ознакомьтесь также с надстройкой для загрузки списка файлов из заданной папки, выполненной на основе функции FilenamesCollection,
а также со способом добавления в таблицу значений ячеек из найденных файлов
Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .txt, но и .TXT и .Txt),
поставьте первой строкой в модуле директиву Option Compare Text
(к примеру, обнаруживались не только файлы .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 ' © EducatedFool excelvba.ru/code/FilenamesCollection ' Получает в качестве параметра путь к папке 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
Комментарии
Добрый день! Помогите в написании макроса.
Задача: подобрать фото в отдельную папку (по имени файла) из бооольшой кучи фотографий (лежат в одной папке). Список необходимых фото (по имени файла) в таблице Excel списком. + необходимо отметить в этой таблице, какие фото подобрались.
заранее спасибо.
Олег.
Огромное спасибо автору!
Добавьте первой строкой в макросе:
Ошибка
Run-time error '52':
Bad file name or number
Ошибка в строке
ДатаСоздания = FileDateTime(ПутьКФайлу)
Не сталкивался с проблемой
Моя функция не может выдавать ошибку, - т.к. в ней отключен вывод сообщений об ошибках
Ни разу с подобным не сталкивался, - функция работает в составе моих программ на тысячах компов.
Какая строка МОЕГО кода выдает ошибку?
Здравствуйте, все работает спасибо) Только выдает ошибку когда название файла содержит нестанадартные знаки, иероглифы там и тому подобное. Не подскажете как исправить?)
Макрос обрабатывает папки с любым количеством файлов, - и десятки тысяч файлов не проблема (не говоря уж о 200 файлах)
Если не работает, - вы что-то не так в коде прописали.
Макрос не работает с большим объемом файлов.. папку с 200 файлами он не обрабатывает. Как поправить?
Здравствуйте, Андрей.
С сетевыми путями (UNC) - тоже все работает.
Вот так написал - и получил список файлов
folder$ = "\\MYCOMP\Users\Public\фото"Убедитесь, что у вас достаточно прав для просмотра списка файлов в указанной папке.
Спасибо. Очень полезная функция. Но, к сожалению, не ищет в сетевых папках без буквы дисковода :-(
Т.е., если папка поиска указана как "\\NetComp1\dir1\dir2" - искать не будет. А не всегда есть возможность присвоить буковку...
Нельзя ли что-нибудь придумать, чтобы работало с сетевыми путями?
С уважением, Андрей.
Спасибо огромное, пользуюсь несколько лет, всё здорово работает,
НО:
обнаружилось неприятное свойство - не работает поиск в сетевых папках, если не назначена буква дисковода. Т.е. "\\Network\dir1\dir2" в пути начала поиска не прокатывает :-(. Нельзя ли что-нибудь "подкрутить", чтобы работало?... А нельзя ли из VBA скрипта запускать поиск в стандартном окне Windows (то, что открывается по нажатию "Win+F"). Думается, во многих случаях это был бы идеальный вариант.
С уважением, Андрей.
Олег, надо внимательно все проверять. Была ли создана предварительно папка с нужным именем, правильно ли указан путь к ней (не написано ли "C:\" с русской буквой С, например), в том ли месте в макросе разместили указанные строки и т.д.
Если VBA даешь команду, он ее исполняет, значит не в том месте команда была дана или ошибку где-то допустили.
Антон, спасибо большое за ответ. Я проверил, но при одновременном выводе списка файлов в листе, копирования в указанную папку, тех файлов, которые отобразились в этом листе, не происходит.
Олег, внимательно смотрите приведенные примеры. Там уже всё есть.
' если нужна гиперссылка на файл во втором столбце
ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
"Открыть файл" & vbNewLine & ИмяФайла
Для копирования файла добавьте в функцию GetAllFileNamesUsingFSO следующие строки
sNewFileName = "С:\папка для копий\Копия " & fil.Name 'имя файла
FileCopy fil, sNewFileName 'копируем файл
При этом папка для копий файлов уже должна быть создана
Возможно ли в этом открывшимся листе Excel, каждому имени файла из списка присвоить гиперссылку на найденный файл?
Подскажите пожалуйста, а как сделать чтобы найденные файлы еще копировались в другую указанную папку?
Отличный сайт, полезные функции. Спасибо автору!!!!
Артем, замените строку
на
ПутьКПапке = "c:\"Подскажите, пожалуйста, как сделать, чтобы поиск происходил по диску С:, а не по рабочему столу?
Большое спасибо. Всё очень хорошо работает. Донесено до народа творчески и аккуратно. Главное идеи и подходы, а детали мы уже сами..... Удачи!!!
Здравствуйте, Allanian.
Для вашей задачи макрос нужно дорабатывать, - можем сделать под заказ.
Оформляйте заказ на сайте, прикрепляйте примеры файлов, и подробно описывайте, что и как должно работать.
здравствуйте, подскажите
Есть например, 10 файлов в названии которых написано имя компьютера, и в самом файле на 2 строчке есть это же имя компьютера.
Как можно собрать названия файлов в эксель в 1 столбик или собрать имена компьютеров из 2 строчки в столбик в экселе. Помогите плис... на работе завал вручную переписывать
При обращении к файлам содержащим немецкие символы типа "умлаут" выдает пустую строку "" в поле 2 - "гиперссылка".
Здравствуйте, Владимир.
Да, дописать макрос возможно.
Доброго времени суток ВСЕМ! Подскажите возможно ли дописать макрос, что бы при задании периода, в "Список файлов в папке" попали только файлы "по дате создания". Спасибо.
Спасибо большое завтра попробую на работе проверить.
Роман, ваш макрос будет выглядеть так:
Помогите исправить макрос с помошью вашей функции т.к. мой макрос не работает в 2010 офисе из за функции Application.FileSearch. пробовал переделать не получилось почемуто не находит ни одного файла в папке. Суть такая есть в папке D:\eq\in несколько файлов типа PRTDSK.001 PRTDSK.002 итд которые надо обработать. Помогите переделать кусок кода под вашу функцию поиска. Заранее благодарен.
Sub rodent()
With Application.FileSearch
.LookIn = "d:\eq\in"
.FileName = "*.*"
If .Execute() > 0 Then
For a = 1 To .FoundFiles.Count
in_file = .FoundFiles.Item(a) ': out_file = Left(in_file, Len(in_file) - 8) & "1\sss.txt"
'in_file = Left(.Filename, 7) & Format(a, "00#")
out_file = .LookIn & "\PRT" & Format(a, "00#") & ".doc"
i = FileLen(in_file)
ReDim in_Array(i) As Byte: ReDim out_Array(i) As Byte
Open in_file For Binary As #1: Get #1, 1, in_Array(): Close #1
Dim io As Long: io = 1
For ii = 1 To i
Select Case in_Array(ii)
Case &H1B: ii = ii + 1
Select Case in_Array(ii)
Case &HE, &HF, &H23, &H30 To &H37, &H3C To &H3E, &H40, &H45 To &H48, &H4D, &H4F, &H50, &H54
Case &H19, &H20, &H21, &H25, &H2D, &H2F, &H33, &H41, &H43, &H49, &H4A, &H4E, _
&H51 To &H53, &H55, &H57, &H61, &H6C, &H6B, &H70, &H77, &H78, &H74: ii = ii + 1
Case &H24, &H5C, &H4B, &H4C, &H59, &H5A, &H3F: ii = ii + 2
Case &H5E: ii = ii + 3
End Select
Case &HE, &HF, &H11 To &H15, &H18, &H7F ', &HC
'Case &HC: out_Array(io) = 10: io = io + 1
'добавить распознование 2х подряд идущих 0D
Case Else: out_Array(io) = in_Array(ii): io = io + 1
End Select
Next ii
ReDim Preserve out_Array(io)
Open out_file For Binary As #1: Put #1, 1, out_Array(): Close #1
Next a
End If
End With
End Sub
попробуйте так:
если несколько расширений надо исключить, - то так:
Здравствуйте!
Вопрос у меня такой, как сделать так, чтобы не показывались файлы с определенным разрешением
Выше вы приводили пример как сделать, чтобы не грузились системные файлы, но у меня не хватает ума переделать строчку, чтобы искались файлы не по полному имени, а по расширению.
Заранее спасибо автору!!!
ИмяФайла = Dir(ПутьКФайлу)
при обращении к файлам типа *.db, *.ini и т.п. выдает пустую строку ""
В данном случае лучше использовать строчку ниже, которая определяет имена любых файлов
ИмяФайла = FSO.GetFileName(ПутьКФайлу)
Никита, я вот сейчас в яндексе написал запрос «VBA дата создания файла»
и, о чудо, по первой же ссылке был нужный код...
Остается только правильно прикрутить этот код к имеющемуся макросу
PS: Если сами не разберетесь, - всегда можно оформить заказ на сайте
Игорь, здравствуйте! Очень полезный макрос, все отлично работает! Но никак не могу разобраться, мне требуется вытащить еще дату создания файла на диске, потому что у вас дата изменения,последнего, на самом-то деле:) Хотел бы вставить строчку вот сюда:
НомерФайла = i
ПутьКФайлу = coll(i)
ИмяФайла = Dir(ПутьКФайлу)
ДатаИзменения = FileDateTime(ПутьКФайлу)'у вас это как ДатаСоздания' было
ДатаСоздания....
РазмерФайла = FileLen(ПутьКФайлу)
Пробовал несколько методов, поискал в интернете, дебагер ошибку выдает постоянно. Количество столбцов в массиве увеличивал конечно же.
Заранее спасибо за помощь!
Игорь, здравствуйте. Написал Вам на e-mail - там все старался пояснить... и файл приложил. Возможно Вы видите другое решение - подскажите... По всем другим нюансам - по электронной почте, а лучше по скайпу... С уважением, Владислав.
Владислав, да мне несложно помочь, - но я не вижу файла с макросом
Исправлять ошибку - 10 секунд, а вот выяснять у вас все подробности - намного больше времени займёт.
Если хотите бесплатной помощи - обратитесь на форумы по Excel
Ну или мне в скайп позвоните (сегодня я добрый)), от вас надо будет: http://ExcelVBA.ru/help
Игорь, здравствуйте. Пытался у Вас просить помощи - а Вы сразу за деньги... Но "надежда умирает последней" - применил корректировку указанных строк и при запуске макроса выскочила ошибка "Runtime error '5'" - через "Debug" выкидывает окно макроса с выделением строки откорректированной строки. Поможете?
Заранее благодарю.
Здравствуйте, Оксана
Это уже сложнее, - значение указанного свойства можно извлечь только из тех файлов, где оно есть
(из произвольного файла, например, текстового, или Excel, такие данные не получить)
В файлах Word в свойствах есть такое
Если из открытого файла считывать, - то так:
x = ThisDocument.BuiltinDocumentProperties("Number of characters with spaces")Если файл Word закрыт - то так:
где 30 - номер свойства (возможно, число понадобится другое)
Доброго дня!!
Вы написали ОЧЕНЬ полезный макрос и от меня Вам БОЛЬШОЕ СПАСИБО!!!!
Я не сильна в написании макросов и поэтому у меня к Вам просьба - подскажите как можно в дополнительной колонке написать данные "Знаков и пробелов" из свойств каждого файла
ошибка - "Sub or function not defined" - возникает потому, что вы скопировали в свой файл только пример использования функции, а саму функцию - нет.
Посмотрите пример в прикреплённом файле - там есть все необходимые макросы и функции
Чтобы отключить поиск скрытых файлов таких как Thumbs.db - надо подправить код:
вместо
написать что-то вроде
как отключить поиск скрытых файлов таких как Thumbs.db если я просто делаю список файлов?
Возникла точно такая же ошибка - "Sub or function not defined". Скачала Ваш макрос - тоже ошибку выдает. Excel- 2010. В чем же может быть дело?
Прошу прощение за беспокойство, уже решил свою проблему.
Здравствуйте, Сергей
Ошибка из-за неправильного использования функции
Покажите свой кусок кода с поиском файла - подскажу, как написать правильно.
Здравствуйте, спасибо за функцию, мне очень пригодилась.
Я функцию использую для поиска конкретного файла. В случае если искомого названия нет, выскакивает ошибка Invalid procedure call or argument. Возможно ли ее как-то локализовать?
слова "не можете" не сильно профессионально звучат из ваших уст )))
все настройки у мня по вашим рекомендациям
и если не открывает, то не НЕ открываю я а прога не открывает
винда 7-ая, новый ноут
никаких сбоев в офисе за последнее время не обнаружено
говорю то что есть.. остальное лирика
с удовольствием выслушаю поправки, в каких случая такое возможно
давайте по сути
Функция FilenamesCollection успешно работает в сотнях моих макросов, на тысячах компов.
Если вы не можете её правильно использовать, - не надо грешить на мой код)
не знаю как у других, но у меня в папке до 2500 фото имена которых мне нужно вытащить (абсолютно все .jpg), а используя FilenamesCollectionEx.xls находит от силы 20-30 не сильно рабочая штука )))
Я "по мотивам" этой процедуры уважаемого Игоря уже давно сделал для себя файл-утилиту для поиска по папкам и подпапкам со всяческими полезными примочками.
В интранете с сетевыми папками вроде бы работает нормально.
Вот здесь файл: http://yadi.sk/d/cpv-QumhFvCG3
А здесь - топик с обсуждением: http://www.excelworld.ru/forum/3-1894-21255-16-1340871322
Отправить комментарий