Макросы в excel список файлов в папке

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

Иногда бывает необходимо заполучить на лист Excel список файлов в заданной папке и ее подпапках. В моей практике такое встречалось неоднократно, например:

• перечислить в приложении к договору на проведение тренинга список файлов из раздаточных материалов для особо щепетильных юристов в некоторых компаниях
• создать список файлов для ТЗ проекта
• сравнить содержимое папок (оригинал и бэкап, например)

Для реализации подобной задачи можно использовать несколько способов.

Способ 1. Скелет из шкафа — функция ФАЙЛЫ

Этот способ использует древнюю функцию ФАЙЛЫ (FILES), оставшуюся в Microsoft Excel с далеких девяностых. Вы не найдете эту функцию в общем списке функций, но для совместимости, она всё ещё остаётся внутри движка Excel, и мы вполне можем её использовать.

Механизм таков:

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

Обратите внимание, что путь должен оканчиваться шаблоном со звездочками:

• *.* — любые файлы
• *.xlsx — книги Excel (только с расширением xlsx)
• *.xl* — любые файлы Excel
• *отчет* — файлы, содержащие слово отчет в названии

и т.д.

2. Создадим именованный диапазон с помощью вкладки Формулы — далее кнопка Диспетчер имен — Создать (Formulas — Names Manger — Create). В открывшемся окне введем любое имя без пробелов (например Мои_файлы) и в поле диапазона выражение:

=ФАЙЛЫ(Лист1!$A$1)

После нажатия на ОК будет создан именованный диапазон с именем Мои_файлы, где хранится список всех файлов из указанной в А1 папки. Останется их оттуда только извлечь.

3. Чтобы извлечь имена отдельных файлов из созданной переменной, используем функцию ИНДЕКС (INDEX), которая в Excel вытаскивает данные из массива по их номеру:

Если лениво делать отдельный столбец с нумерацией, то можно воспользоваться костылем в виде функции СТРОКИ (ROWS), которая будет подсчитывать количество заполненных строк с начала списка автоматически:

=ИНДЕКС(Мои_файлы; ЧСТРОК($B$3:B3))

Ну, и скрыть ошибки #ССЫЛКА! в конце списка (если вы протягиваете формулу с запасом) можно стандартной функцией ЕСЛИОШИБКА (IFERROR):

=ЕСЛИОШИБКА(ИНДЕКС(Мои_файлы; ЧСТРОК($B$3:B3)); «»)

Важное примечание: формально функция ФАЙЛЫ относится к макро-функциям, поэтому необходимо будет сохранить ваш файл в формате с поддержкой макросов (xlsm или xlsb).

Способ 2. Готовый макрос для ленивых

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

Для добавления макроса в вашу книгу нажмите сочетание клавиш Alt+F11, или кнопку Visual Basic на вкладке Разработчик (Developer), в открывшемся окне редактора Visual Basic вставьте новый модуль через меню Insert — Module и скопируйте туда текст этого макроса:

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
    
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
    
    'добавляем лист и выводим на него шапку таблицы
    ActiveWorkbook.Sheets.Add
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
    Range("B1").Value = "Путь"
    Range("C1").Value = "Размер"
    Range("D1").Value = "Дата создания"
    Range("E1").Value = "Дата изменения"
    
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub


Private Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)

    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)

    r = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
    'выводим данные по файлу
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = FileItem.Path
        Cells(r, 3).Formula = FileItem.Size
        Cells(r, 4).Formula = FileItem.DateCreated
        Cells(r, 5).Formula = FileItem.DateLastModified
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
    
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Columns("A:E").AutoFit

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing

End Sub

Для запуска макроса нажмите сочетание клавиш Alt+F8,или кнопку Макросы (Macros) на вкладке Разработчик (Developer), выберите наш макрос FileList и нажмите кнопку Выполнить (Run). В диалоговом окне выберите любую папку или диск и — вуаля!

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

Cells(r, 2).Formula = FileItem.Path

на

Cells(r, 2).Formula = «=HYPERLINK(«»» & FileItem.Path & «»»)»

Способ 3. Мощь и красота — надстройка Power Query

Power Query — это очень мощная и при этом бесплатная надстройка для Excel от Microsoft, упрощающая множество задач по загрузке и трансформации данных. В нашей ситуации она тоже может здорово помочь.

Если у вас Excel 2016 или новее, то Power Query уже встроена в Excel по умолчанию, поэтому просто на вкладке Данные выберите команду Создать запрос / Получить данные — Из файла — Из папки (Create Query / Get Data — From file — From folder). Если у вас Excel 2010-2013, то Power Query нужно будет скачать с сайта Microsoft и установить как отдельную надстройку и она появится у вас в Excel в виде отдельной вкладки Power Query. На ней будет аналогичная кнопка Из файла — Из папки (From file — From folder).

В открывшемся окне нужно будет указать папку, содержимое которой мы хотим получить. После нажатия на ОК Power Query обшарит указанную папку и все вложенные подпапки и выдаст на экран окно с предварительным просмотром результатов:

Если внешний вид списка вас устраивает, то можно смело жать внизу кнопку Загрузить (Load), чтобы залить эти данные на новый лист. Если же хочется дополнительно обработать список (удалить лишние столбцы, отобрать только нужные файлы и т.п.), то нужно выбрать команду Изменить / Преобразовать данные (Edit / Transform Data).

Поверх окна Excel откроется окно редактора Power Query, где мы увидим список всех наших файлов в виде таблицы:

Дальше возможны несколько вариантов:

• Если нужны только файлы определенного типа, то их можно легко отобрать с помощью фильтра по столбцу Extension:

  

• Аналогичным образом фильтрами по столбцам Date accessed, Date modified или Date created можно отобрать файлы за нужный период (например, созданные только за последний месяц и т.п.):

  

• Если нужно получить данные не из всех папок, то фильтруем по столбцу Folder Path, чтобы оставить только те строки, где путь содержит/не содержит нужные имена папок:

  

• Там же можно выполнить сортировку файлов по любому столбцу, если требуется.

После того, как необходимые файлы отобраны, можно смело удалить ненужные столбцы, щелкнув по заголовку столбца правой кнопкой мыши и выбрав команду Удалить (Remove column). Это, кстати, уже никак не повлияет на фильтрацию или сортировку нашего списка:

Если в будущем планируется подсчитывать количество файлов в каждой папке (например, для контроля поступивших заявок или подсчета статистики по заявкам), то имеет смысл дополнительно сделать ещё пару действий:

• Щелкните правой кнопкой мыши по столбцу Folder Path и выберите команду Дублировать столбец (Duplicate Column).
• Выделите скопированный столбец и на вкладке Преобразование (Transform) выберите Разделить столбец — По разделителю (Split Column — By delimiter)

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

Получившиеся столбцы можно переименовать (Диск, Папка1, Папка2 и т.д.), просто щёлкнув дважды по заголовку каждого.

И, наконец, когда список готов, то его можно выгрузить на лист с помощью команды Главная — Закрыть и загрузить — Закрыть и загрузить в… (Home — Close & Load — Close & Load to…):

Дополнительным бонусом можно сделать еще один столбец с функцией ГИПЕРССЫЛКА (HYPERLINK), которая создаст красивые стрелочки-ссылки для моментального перехода к каждому файлу:

Мелочь, а приятно

И вдвойне приятно, что в будущем, при изменении содержимого исходной папки, достаточно будет просто щелкнуть мышью по нашей таблице и выбрать команду Обновить (Refresh) — и Power Query выполнит всю цепочку запрограммированных нами единожды действий уже автоматически, отобразив все изменения в составе папки.

Ссылки по теме

• Что такое макрос, куда вставлять код макроса на Visual Basic
• Создание резервных копий ценных файлов
• Что такое Power Query и что можно делать с её помощью

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

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

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

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

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

Пример 1

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

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

Sub Primer1() Dim fso, myPath, myFolder, myFile, myFiles(), i ‘Записываем в переменную myPath полное имя папки myPath = «C:DATAТекущая папка»     ‘Создаем новый экземпляр FileSystemObject     Set fso = CreateObject(«Scripting.FileSystemObject»)     ‘Присваиваем переменной myFolder ссылку на объект Folder     Set myFolder = fso.GetFolder(myPath)     ‘Проверяем, есть ли файлы в папке myFolder     If myFolder.Files.Count = 0 Then         MsgBox «В папке «» & myPath & «» файлов нет»         Exit Sub     End If ‘Задаем массиву размерность ReDim myFiles(1 To myFolder.Files.Count)     ‘Загружаем в массив полные имена файлов     For Each myFile In myFolder.Files         i = i + 1         myFiles(i) = myFile.Path     Next ‘Просматриваем первый элемент массива MsgBox myFiles(1) End Sub

Используемые переменные:

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

Пример 2

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

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19

Sub Primer2() Dim myPath, myFolder As Folder, myFile As File, i ‘Записываем в переменную myPath полное имя папки myPath = «C:DATAТекущая папка»     ‘Создаем новый экземпляр FileSystemObject     Dim fso As New FileSystemObject     ‘Присваиваем переменной myFolder ссылку на объект Folder     Set myFolder = fso.GetFolder(myPath)     ‘Проверяем, есть ли файлы в папке myFolder     If myFolder.Files.Count = 0 Then         MsgBox «В папке «» & myPath & «» файлов нет»         Exit Sub     End If     ‘Записываем имена файлов в первый столбец активного листа     For Each myFile In myFolder.Files         i = i + 1         Cells(i, 1) = myFile.Name     Next End Sub

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

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

---

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

---

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

• Для спонсоров 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

I have searched other questions but cant find what I need.
I have a folder with lost of sub folder, lots of sub folders in them and so on until I get to a list of hundreds of documents in them.

I need a macro in Excel to list the documents in every sub folder of a given directory and also hyperlink to the document.

I have found a macro that will list the documents and create a hyperlink to them in 1 directory but does not delve into the sub directories.

I’m hoping someone can help.

Thanks.

Tom

The macro I am using is:

Option Compare Text
Option Explicit

Function Excludes(Ext As String) As Boolean
    'Function purpose:  To exclude listed file extensions from hyperlink listing

Dim X, NumPos As Long

 'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")

On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0

End Function

Sub HyperlinkFileList()
 'Macro purpose:  To create a hyperlinked list of all files in a user
 'specified directory, including file size and date last modified
 'NOTE:  The 'TextToDisplay' property (of the Hyperlink object) was added
 'in Excel 2000.  This code tests the Excel version and does not use the
 'Texttodisplay property if using XL 97.

Dim fso As Object, _
ShellApp As Object, _
file As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer

 'Turn off screen flashing
Application.ScreenUpdating = False

 'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")

 'Prompt user to select a directory
Do
    Problem = False
    Set ShellApp = CreateObject("Shell.Application"). _
    Browseforfolder(0, "Please choose a folder", 0, "c:\")

    On Error Resume Next
     'Evaluate if directory is valid
    Directory = ShellApp.self.Path
    Set SubFolder = fso.GetFolder(Directory).Files
    If Err.Number <> 0 Then
        If MsgBox("You did not choose a valid directory!" & vbCrLf & _
        "Would you like to try again?", vbYesNoCancel, _
        "Directory Required") <> vbYes Then Exit Sub
        Problem = True
    End If
    On Error GoTo 0
Loop Until Problem = False

 'Set up the headers on the worksheet
With ActiveSheet
    With .Range("A1")
        .Value = "Listing of all files in:"
        .ColumnWidth = 40
         'If Excel 2000 or greater, add hyperlink with file name
         'displayed.  If earlier, add hyperlink with full path displayed
        If Val(Application.Version) > 8 Then 'Using XL2000+
            .Parent.Hyperlinks.Add _
            Anchor:=.Offset(0, 1), _
            Address:=Directory, _
            TextToDisplay:=Directory
        Else 'Using XL97
            .Parent.Hyperlinks.Add _
            Anchor:=.Offset(0, 1), _
            Address:=Directory
        End If
    End With
    With .Range("A2")
        .Value = "File Name"
        .Interior.ColorIndex = 15
        With .Offset(0, 1)
            .ColumnWidth = 15
            .Value = "Date Modified"
            .Interior.ColorIndex = 15
            .HorizontalAlignment = xlCenter
        End With
    End With
End With

 'Adds each file, details and hyperlinks to the list
For Each file In SubFolder
    If Not Excludes(Right(file.Path, 3)) = True Then
        With ActiveSheet
             'If Excel 2000 or greater, add hyperlink with file name
             'displayed.  If earlier, add hyperlink with full path displayed
            If Val(Application.Version) > 8 Then 'Using XL2000+
                .Hyperlinks.Add _
                Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                Address:=file.Path, _
                TextToDisplay:=file.Name
            End If
             'Add date last modified, and size in KB
            With .Range("A65536").End(xlUp)
                .Offset(0, 1) = file.datelastModified

            End With
        End With
    End If
Next

End Sub

CURRENT UPDATE:
‘Global Declaration for Start Row

Public lngRow As Long

Sub pReadAllFilesInDirectory()

Dim strFolderPath               As String
Dim BlnInclude_subfolder        As Boolean

'Set Path here
strFolderPath = "C:UsersThomasDocumentstest file"

'set start row
lngRow = 1

'Set this true if you want list of sub-folders as well
BlnInclude_subfolder = True

'---------- Reading of files in folders and sub-folders------
Call ListMyFiles(strFolderPath, BlnInclude_subfolder)
'---------- Reading of files in folders and sub-folders------

End Sub

Sub ListMyFiles(mySourcePath As String, blnIncludeSubfolders As Boolean)

Dim MyObject            As Object
Dim mySource            As Object
Dim mySubFolder         As Object
Dim myfile              As Object
Dim iCol                As Long

Set MyObject = CreateObject("Scripting.FileSystemObject")
Set mySource = MyObject.GetFolder(mySourcePath)

'Loop in each file in Folder
For Each myfile In mySource.Files

  iCol = 1
  Sheet1.Cells(lngRow, iCol).Value = myfile.Name  'File Name


       ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    myfile.Path, TextToDisplay:=myfile.Name


    iCol = iCol + 1
    Sheet1.Cells(lngRow, iCol).Value = myfile.Path  'File Path/Location
   lngRow = lngRow + 1

Next

If blnIncludeSubfolders Then
    For Each mySubFolder In mySource.SubFolders
        Call ListMyFiles(mySubFolder.Path, True)
    Next
End If

THE PROBLEM WITH THE ABOVE IS THE HYPERLINK
I WANT THE HYPERLINK TO BE IN THE SAME CELL THAT THE NAME OF THE FILE IS IN HOWEVER THE HYPERLINK ENDS UP IN WHAT EVER CELL WAS ACTIVE BEFORE I RAN THE MACRO AND IS THE NAME AND LINK TO THE FINAL FILE FOUND

Функция 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 минут назад