Vba excel коллекция файлов - Word и Excel - помощь в работе с программами

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

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

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

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

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

Пример 1

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

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

‘Просматриваем первый элемент массива

MsgBox myFiles(1)

End Sub

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

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

Пример 2

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

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

End Sub

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

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

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

Источник

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

Используется рекурсивный перебор папок, до заданного уровня вложенности.
В процессе перебора папок, пути у найденным файлам помещаются в коллекцию (объект типа Collection) для последующего перебора.

К статье прикреплено 2 примера файла с макросами на основе этой функции:

Пример в файле FilenamesCollection.xls выводит список файлов на чистый лист новой книги (формируя заголовки)
Пример в файле FilenamesCollectionEx.xls более функционален — он, помимо списка файлов из папки, отображает размер файла, и дату его создания, а также формирует в ячейках гиперссылки на найденные файлы.
Вывод списка производится на лист запуска, параметры поиска файлов задаются в ячейках листа (см. скриншот)

Смотрите также расширенную версию макроса на базе этой функции:

Макрос FolderStructure выводит в таблицу Excel список файлов и подпапок с отображением структуры (вложенности файлов и подпапок)

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

Внимание: если требуется, чтобы поиск не зависел от регистра символов в маске файла
(к примеру, обнаруживались не только файлы .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

301786 просмотров

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

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

Источник

Private Sub cmdCopy_Click()
' Выполняет копирование указанной папки со всем его содержимым с одного места
' на другое. Метод Copy идентичен операции, выполняемой с помощью
' FileSystemObject.CopyFolder. Однако обратите внимание на то,
' что данный метод дает возможность копирования нескольких папок.
On Error Resume Next
If fso.FolderExists("C:WindowsCursors") Then
  If fso.FolderExists("C:Documents and SettingsAll UsersДокументы") Then
    Dim fld, s
    Set fld = fso.GetFolder("C:WindowsCursors")
    Set s = fso.GetFolder("C:Documents and SettingsAll UsersДокументы")
    fld.Copy sFolder
    s.Copy sFolder
    MsgBox "Копирование завершено"
Else
    MsgBox "Папки: ""C:WindowsCursors"" и ""C:Documents and SettingsAll UsersДокументы"" - не существуют"
  End If
End If
End Sub
 
Private Sub cmdMove_Click()
' Перемещает указанную папку со всем содержимым с одного места на другое.
' Результаты использования метода Move для объектов Folder идентичны получаемым
' с помощью выражений FileSystemObject.MoveFolder. Однако следует отметить,
' что данный метод позволяет перемещать несколько папок.
Dim fld
If fso.FolderExists("C:FsoTestFsoMoveTest") Then
    Set fld = fso.GetFolder("C:FsoTestFsoMoveTest")
    fld.Move "C:"
    s.Move "C:"
    MsgBox "Папка перемещена"
Else
    MsgBox "Папка C:FsoTestFsoMoveTest не существует"
End If
End Sub
 
'**********************************************************************************
'----------------------------------------------------------------------------------
 
'Объект File
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
 
Private Sub cmdFType_Click()
' Возвращает словесное описание о типе файла.
If fso.FileExists("C:AUTOEXEC.BAT") Then
Dim f, s
  Set f = fso.GetFile("C:AUTOEXEC.BAT")
  s = f.Name & " - " & f.Type
  MsgBox s
Else
    MsgBox "Файл C:AUTOEXEC.BAT не существует"
End If
End Sub
 
Private Sub cmdfDrive_Click()
' Возвращает символ того дисковода, на котором находится указанный файл.
If fso.FileExists(sPath) Then
  Dim f, s
  Set f = fso.GetFile(sPath)
  s = f.Name & " находится на диске " & f.Drive
  MsgBox s
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdFParentFolder_Click()
' Возвращает объект родительской папки(содержащей данный файл).
If fso.FileExists(sPath) Then
    Dim f, s
    Set f = fso.GetFile(sPath)
    s = f.Name & " находится в папке " & f.ParentFolder
    MsgBox s
Else
    MsgBox "Файл " & sPath & " не существует"
End If
End Sub
Private Sub cmdFLastModified_Click()
' Возвращает дату и время последней модификации файла.
If fso.FileExists(sPath) Then
  Dim f, message
  Set f = fso.GetFile(sPath)
  message = "Файл " & sPath & " был изменен: " & f.DateLastModified
  MsgBox message
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdFDateCreated_Click()
' Возвращает дату и время создания указанного файла.
If fso.FileExists(sPath) Then
  Dim f
  Set f = fso.GetFile(sPath)
  MsgBox "Файл " & sPath & " создан: " & f.DateCreated
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdFLastAccessed_Click()
' Возвращает дату и время последнего доступа к указанному файлу.
If fso.FileExists(sPath) Then
  Dim f, message
  Set f = fso.GetFile(sPath)
  message = "Файл " & sPath & " был открыт: " & f.DateLastAccessed
  MsgBox message
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdFShortName_Click()
' Возвращает короткое имя без пути, используемое программами, для которых
' требуется имя, соответствующее применявшемуся ранее соглашению DOS 8.3.
Dim f, s, a
If Not fso.FolderExists(sFolder) Then
  fso.CreateFolder sFolder
End If
Set a = fso.CreateTextFile("C:TestFileSystemObject - FileShortName.txt", True)
Set f = fso.GetFile("C:TestFileSystemObject - FileShortName.txt")
s = "Короткое имя для " & f.Name
s = s & " : " & f.ShortName
MsgBox s
End Sub
 
Private Sub cmdFShortPath_Click()
' Возвращает короткий путь, используемый программами, для которых
' требуется задание пути, соответствующее применявшемуся ранее соглашению DOS 8.3.
Dim f, s, s1, a
If Not fso.FolderExists(sFolder) Then
  fso.CreateFolder sFolder
End If
If Not fso.FolderExists("C:TestFileSystemObject - FileShortPath") Then
 fso.CreateFolder "C:TestFileSystemObject - FileShortPath"
End If
 Set a = fso.CreateTextFile("C:TestFileSystemObject - FileShortPathTest.txt", True)
 Set f = fso.GetFile("C:TestFileSystemObject - FileShortPathTest.txt")
 s = "Короткий путь для " & f.Name
 s = s & ": " & vbCrLf
 s = s & f.ShortPath & vbCrLf & vbCrLf
 s1 = "Обычный путь для " & f.Name
 s1 = s1 & ": " & vbCrLf
 s1 = s1 & "C:TestFileSystemObject - FileShortPathTest.txt"
 MsgBox s & s1
End Sub
 
Private Sub cmdFAttributes_Click()
' Устанавливает или возвращает атрибуты файла.
' Ключи:
' 0 - Normal (Обычный файл. Атрибуты не установлены. По умолчанию)
' 1 - ReadOnly (Только для чтения. Установлен атрибут чтение/запись)
' 2 - Hidden (Скрытый файл. Установлен атрибут чтение/запись)
' 4 - System (Системный файл. Установлен атрибут чтение/запись)
' 8 - Volume (Метка тома дискового накопителя. Установлен атрибут только для чтения)
' 16 - Directory (Папка или каталог. Установлен атрибут только для чтения)
' 32 - Archive (Файл был изменен после последнего резервирования. Установлен атрибут чтение/запись)
' 1024 - Alias (Ссылка или ярлык. Установлен атрибут только для чтения)
' 2048 - (Compressed Сжатый файл. Установлен атрибут только для чтения)
Dim fld
If Not fso.FileExists(sPath) Then
   MsgBox "Файл " & sPath & " не существует"
Else
 Set fld = fso.GetFile(sPath)
 If fld.Attributes And 2 Then
   fld.Attributes = fld.Attributes - 2
   MsgBox "Атрибут Скрытый для файла " & sPath & " - сброшен"
 Else
  fld.Attributes = fld.Attributes + 2
  MsgBox "Атрибут Скрытый для файла " & sPath & " - установлен"
 End If
End If
' Примечание: Остальные атрибуты устанавливаются по аналогии, т.е. вместо
' fld.Attributes = fld.Attributes + 2-2 нужно написать
' fld.Attributes = fld.Attributes + 1-1 (т.е. атрибут - Только для чтения) и т.д.
End Sub
 
Private Sub cmdFCopy_Click()
' Выполняет копирование указанного файла с одного места на другое.
' Примечание: в данном примере будет скопирован не сам файл autoexec.bat, а его
' содержимое и затем это содержимое будет скопировано в файл FsoTest.txt
Dim f
If fso.FileExists("C:autoexec.bat") Then
   Set f = fso.GetFile("C:autoexec.bat")
   f.Copy sPath
   MsgBox "Копирование завершено"
Else
    MsgBox "Файл C:autoexec.bat не существует"
End If
End Sub
 
Private Sub cmdFMove_Click()
' Перемещает указанный файл с одного места на другое.
Dim f
If fso.DriveExists("C") Then
  If Not fso.FolderExists(sFolder) Then
    fso.CreateFolder sFolder
  End If
  If Not fso.FileExists(sPath) Then
    MsgBox "Файл " & sPath & "  не существует"
  Else
    Set f = fso.GetFile(sPath)
    f.Move "C:"
    MsgBox "В папку ""C:"" перемещен файл FsoTest.txt из папки " & sFolder
  End If
Else
    MsgBox "Диск C: не существует"
End If
End Sub
 
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
'----------------------------------------------------------------------------------
 
' Объект TextStream
'##################################################################################
 
Private Sub cmdColumn_Click()
' Возвращает номер позиции текущего символа в текстовый файле.
Const ForReading = 1, ForWriting = 2
If fso.FileExists(sPath) Then
  Dim ts, m
  Set ts = fso.OpenTextFile(sPath, ForWriting, True)
  ts.Write "Test string"
  ts.Close
  Set ts = fso.OpenTextFile(sPath, ForReading)
  m = ts.ReadLine
  MsgBox "Позиция текущего символа в файле " & sPath & " - " & ts.Column
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdLine_Click()
' Возвращает текущий номер строки в текстовом файле.
Const ForReading = 1, ForWriting = 2
If fso.FileExists(sPath) Then
  Dim ts, ra
  Set ts = fso.OpenTextFile(sPath, ForWriting, True)
  ts.Write "Тестовая строка." & vbCrLf & "Показывает пример использования свойства:" & _
            vbCrLf & "Line"
  Set ts = fso.OpenTextFile(sPath, ForReading)
  ra = ts.ReadAll
  MsgBox "Текущий номер строки в файле " & sPath & " - " & ts.Line
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdRead_Click()
' Читает указанное количество символов из текстового файла.
If fso.FileExists(sPath) Then
    Dim ts
    Set ts = fso.OpenTextFile(sPath, ForReading)
    MsgBox "Первые 8 символов в файле " & sPath & " - " & vbCrLf & ts.Read(8)
Else
    MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdReadAll_Click()
' Считывает весь текстовый файл.
If fso.FileExists(sPath) Then
    Dim ts
    Set ts = fso.OpenTextFile(sPath, ForReading)
    MsgBox "Содержимое файла " & sPath & " - " & vbCrLf & ts.ReadAll
Else
    MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdReadLine_Click()
' Читает полную строку.
If fso.FileExists(sPath) Then
 Dim ts
 Set ts = fso.OpenTextFile(sPath, ForWriting, True)
 ts.WriteLine "Тестовая строка."
 ts.WriteLine "Показывает пример использования метода:"
 ts.WriteLine "ReadLine"
 ts.Close
 Set ts = fso.OpenTextFile(sPath, ForReading)
 MsgBox ts.ReadLine
 MsgBox ts.ReadLine
 MsgBox ts.ReadLine
Else
 MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdSkip_Click()
' Пропускает указанное число символов при чтении из текстового файла.
If fso.FileExists(sPath) Then
 Dim ts
 Set ts = fso.OpenTextFile(sPath, ForWriting, True)
 ts.Write "Тестовая строка показывающая пример использование метода Scip"
 Set ts = fso.OpenTextFile(sPath, ForReading)
 ts.Skip (8)
 MsgBox ts.ReadLine & vbCrLf & "В файле " & sPath & " пропущено 8 первых символов."
Else
 MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdScipLine_Click()
' Пропускает следующую строку при чтении из текстовый файла.
If fso.FileExists(sPath) Then
  Dim ts
  Set ts = fso.OpenTextFile(sPath, ForWriting, True)
  ts.Write "Тестовая строка." & vbCrLf & "Показывает пример использования метода: " & _
           "ScipLine"
  Set ts = fso.OpenTextFile(sPath, ForReading)
  ts.SkipLine
  MsgBox ts.ReadLine & vbCrLf & "В файле " & sPath & " пропущена первая строка."
Else
 MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdWrite_Click()
' Записывает указанную строку в текстовый файл.
If fso.FileExists(sPath) Then
    Dim ts
    Set ts = fso.OpenTextFile(sPath, ForWriting, True)
    ts.Write "Пример использования метода Write"
    ts.Close
    Set ts = fso.OpenTextFile(sPath, ForReading)
    MsgBox ts.ReadLine
Else
    MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdWriteLine_Click()
' Записывает в текстовый файл указанную строку и символ новой строки.
If fso.FileExists(sPath) Then
    Dim ts
    Set ts = fso.OpenTextFile(sPath, ForWriting, True)
    ts.WriteLine "Тестовая строка."
    ts.WriteLine "Показывает пример использования метода:"
    ts.WriteLine "WriteLine"
    Set ts = fso.OpenTextFile(sPath, ForReading)
    MsgBox ts.ReadAll
Else
    MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
Private Sub cmdWriteBlankLines_Click()
' Записывает в текстовый файл указанное число пустых строк.
If fso.FileExists(sPath) Then
  Dim ts
  Set ts = fso.OpenTextFile(sPath, ForWriting, True)
  ts.WriteBlankLines 6
  ts.WriteLine "Тестовая строка."
  ts.WriteLine "Показывает пример использования метода:"
  ts.WriteLine "WriteBlankLines"
  Set ts = fso.OpenTextFile(sPath, ForReading)
  MsgBox ts.ReadAll
Else
  MsgBox "Файл " & sPath & " не существует"
End If
End Sub
 
'##################################################################################
'----------------------------------------------------------------------------------
 
Private Sub cmdDriveExample_Click()
frmDrive.Show
End Sub
 
Private Sub cmdFoFExample_Click()
frmFoldrerFile.Show
End Sub
 
Private Sub lblInfo_Click(Index As Integer)
If Index = 8 Then
  ShellExecute 0, vbNullString, _
  "mailto:Axel.Coding@gmail.com?subject=FileSystemObject", vbNullString, _
  vbNullString, SW_SHOWNORMAL
End If
End Sub

Источник

Return to VBA Code Examples

In this tutorial, you will learn how to get names of all files in a folder and put them into a Worksheet.

Instead, if you want to learn how to check if a file exists, you can click on this link: VBA File Exists

Using the FileSystemObject to Get the List of Files in a Folder

VBA allows you to list all files from a folder, using the FileSystemObject.

We will show how to get a list of files in the folder C:VBA Folder and put it into the first column of the Worksheet. This folder consists of 5 files, as shown in Image 1:

Image 1. Files in folder C:VBA Folder

Here is the code:

Sub LoopThroughFiles ()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oFolder = oFSO.GetFolder("C:VBA Folder")

For Each oFile In oFolder.Files

    Cells(i + 1, 1) = oFile.Name

    i = i + 1

Next oFile

End Sub

In the example, first create an object of the class Scripting.FileSystemObject:

Set oFSO = CreateObject("Scripting.FileSystemObject")

Then set the folder using the method GetFolder:

Set oFolder = oFSO.GetFolder("C:VBA Folder")

Next loop through each file in oFolder, using oFile.Name to get the name of every file in the folder and write it in the next empty row:

For Each oFile In oFolder.Files

    Cells(i + 1, 1) = oFile.Name
    i = i + 1

Next oFile

Image 2. Worksheet with the list of files in the folder

As you can see in Image 2, all 5 files from the C:VBA Folder are listed in the first column.

VBA Coding Made Easy

Stop searching for VBA code online. Learn more about AutoMacro — A VBA Code Builder that allows beginners to code procedures from scratch with minimal coding knowledge and with many time-saving features for all users!

Learn More!

Источник

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

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

Источник

The Dir function is the way to go, but the problem is that you cannot use the Dir function recursively, as stated here, towards the bottom.

The way that I’ve handled this is to use the Dir function to get all of the sub-folders for the target folder and load them into an array, then pass the array into a function that recurses.

Here’s a class that I wrote that accomplishes this, it includes the ability to search for filters. (You’ll have to forgive the Hungarian Notation, this was written when it was all the rage.)

Private m_asFilters() As String
Private m_asFiles As Variant
Private m_lNext As Long
Private m_lMax As Long

Public Function GetFileList(ByVal ParentDir As String, Optional ByVal sSearch As String, Optional ByVal Deep As Boolean = True) As Variant
    m_lNext = 0
    m_lMax = 0

    ReDim m_asFiles(0)
    If Len(sSearch) Then
        m_asFilters() = Split(sSearch, "|")
    Else
        ReDim m_asFilters(0)
    End If

    If Deep Then
        Call RecursiveAddFiles(ParentDir)
    Else
        Call AddFiles(ParentDir)
    End If

    If m_lNext Then
        ReDim Preserve m_asFiles(m_lNext - 1)
        GetFileList = m_asFiles
    End If

End Function

Private Sub RecursiveAddFiles(ByVal ParentDir As String)
    Dim asDirs() As String
    Dim l As Long
    On Error GoTo ErrRecursiveAddFiles
    'Add the files in 'this' directory!


    Call AddFiles(ParentDir)

    ReDim asDirs(-1 To -1)
    asDirs = GetDirList(ParentDir)
    For l = 0 To UBound(asDirs)
        Call RecursiveAddFiles(asDirs(l))
    Next l
    On Error GoTo 0
Exit Sub
ErrRecursiveAddFiles:
End Sub
Private Function GetDirList(ByVal ParentDir As String) As String()
    Dim sDir As String
    Dim asRet() As String
    Dim l As Long
    Dim lMax As Long

    If Right(ParentDir, 1) <> "" Then
        ParentDir = ParentDir & ""
    End If
    sDir = Dir(ParentDir, vbDirectory Or vbHidden Or vbSystem)
    Do While Len(sDir)
        If GetAttr(ParentDir & sDir) And vbDirectory Then
            If Not (sDir = "." Or sDir = "..") Then
                If l >= lMax Then
                    lMax = lMax + 10
                    ReDim Preserve asRet(lMax)
                End If
                asRet(l) = ParentDir & sDir
                l = l + 1
            End If
        End If
        sDir = Dir
    Loop
    If l Then
        ReDim Preserve asRet(l - 1)
        GetDirList = asRet()
    End If
End Function
Private Sub AddFiles(ByVal ParentDir As String)
    Dim sFile As String
    Dim l As Long

    If Right(ParentDir, 1) <> "" Then
        ParentDir = ParentDir & ""
    End If

    For l = 0 To UBound(m_asFilters)
        sFile = Dir(ParentDir & "" & m_asFilters(l), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem)
        Do While Len(sFile)
            If Not (sFile = "." Or sFile = "..") Then
                If m_lNext >= m_lMax Then
                    m_lMax = m_lMax + 100
                    ReDim Preserve m_asFiles(m_lMax)
                End If
                m_asFiles(m_lNext) = ParentDir & sFile
                m_lNext = m_lNext + 1
            End If
            sFile = Dir
        Loop
    Next l
End Sub

Источник