Получение списка файлов в папке и подпапках средствами VBA Макросы VBA Excel Обработка файлов Гиперссылки Список файлов Средства Windows Работа с файлами Разное

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

 

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

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

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

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

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

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

Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .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.xls	35 КБ	10367	4 часа 33 минуты назад
FilenamesCollectionEx.xls	56 КБ	9927	5 часов 9 минут назад