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

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	Помогите, пожалуйста. Как в определенной папке с помощью макроса найти и открыть фаил с названием из ячейки??? Заранее, спасибо большое

Johny Пользователь Сообщений: 2737 Регистрация: 21.12.2012	А файл какой? Excel? There is no knowledge that is not power

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	да. в 2003 экселе пытаюсь написать

Johny

Пользователь

Сообщений: 2737
Регистрация: 21.12.2012

23.05.2013 11:40:58

Код

Sub f()

    Dim f As String, folder As String, file_name As String

    'Папка для поиска
    folder = "C:Temp"
    
    'Ячейка с именем файла
    file_name = Range("A1")
    
    f = Dir(folder)
    While Not Len(f) = 0
        If f = file_name Then
            Workbooks.Open folder & f
        End If
        f = Dir()
    Wend

End Sub

There is no knowledge that is not power

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	а как сделать, чтобы выбор варианта ответа при появлении диалогового окна был автоматический, или чтобы оно вообще не вылазило???

Johny

Пользователь

Сообщений: 2737
Регистрация: 21.12.2012

24.05.2013 14:28:11

Код
Application.DisplayAlerts = False ..... ..... ..... Application.DisplayAlerts = True

Изменено: Johny — 24.05.2013 14:28:36

There is no knowledge that is not power

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	а можно ли сделать, чтобы он искал документ в поддиректориях???

Johny

Пользователь

Сообщений: 2737
Регистрация: 21.12.2012

31.05.2013 17:18:58

Ставим галку: Tools -> References -> Microsoft Scripting Runtime

Код

Private file_name As String
Private f As File, fld As folder

Sub SearchAndOpen()

    Dim source_folder As String
    Dim fso As New FileSystemObject

    'Папка для поиска
    source_folder = "C:TempDir"
    
    'Ячейка с именем файла
    file_name = Range("A1")
    
    Call EnumerateFiles(fso.GetFolder(source_folder))

End Sub

Private Sub EnumerateFiles(root_folder As folder)

    For Each f In root_folder.Files
        If f.Name = file_name Then
            Workbooks.Open f.Path
        End If
    Next
    
    For Each fld In root_folder.SubFolders
        Call EnumerateFiles(fld)
    Next
    
End Sub

Изменено: Johny — 31.05.2013 17:19:49

There is no knowledge that is not power

Hugo

Пользователь

Сообщений: 23251
Регистрация: 22.12.2012

#10

31.05.2013 17:29:09

Я чего-то не понимаю?
Если есть имя файла — то зачем искать? Взяли и открыли. Если ошибка — обработали.
А искать может быть долго — если например файлов тысячи. Да и код с таким поиском больно длинный — хватает ведь 3-х строк:

Код
Sub f() On Error GoTo err_: Workbooks.Open "C:Temp" & Range("A1"): Exit Sub err_: MsgBox "Нет такого файла!" End Sub

Юрий М Модератор Сообщений: 60575 Регистрация: 14.09.2012 Контакты см. в профиле	Я тоже не понимаю смысла в поиске…

KuklP Пользователь Сообщений: 14868 Регистрация: 21.12.2012 E-mail и реквизиты в профиле.	Я сам — дурнее всякого примера! …

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	Просто документов очень много. и постоянно открывать файлы под определенными названиями….. смысл тогда составления макроса… Пишу для автоматизации процессов обработки информации, и остановилась на этом моменте.

Hugo

Пользователь

Сообщений: 23251
Регистрация: 22.12.2012

Если например ситуации такие:
— есть точный список названий файлов
— в определённом месте (папки/подпапки) регулярно генерятся файлы (известна часть имени, или даже не известна)
— нужно открыть все файлы определённой папки/подпапки
— есть какая-то другая система в этих файлах
и открывать такие файлы предстоит регулярно — то есть смысл один раз и надолго облегчить себе работу макросом.
Если же никакой системы нет — то и макросом открывать файлы нет смысла.
Другое дело, что если обработка этих открываемых файлов предстоит макросом — то можно в этот же макрос вписать диалог выбора этих файлов. Т.е. запустили макрос, в диалоге указали сразу все нужные файлы, получили готовый результат.

lenok

Пользователь

Сообщений: 39
Регистрация: 23.05.2013

Есть огромный отчет. после обработки макросом, надо, чтобы он брал имя файла из определенной ячейки и открывал фаил с таким именем. информации много, и такой отчет обрабатывается каждый месяц. примерное кол-во файлов на один отчет больше 1000, поэтому, сами понимаете, что открывать каждый, это рутина. таких отчетов за один месяц 30 штук. соответственно, около 30000 существующих файлов…вот как-то так все глобально……

просто открыть, с этим мы разобрались….. но некоторые файлы находятся в поддиректориях, и постоянно происходят какие-то перемещения в этой директории…

Hugo

Пользователь

Сообщений: 23251
Регистрация: 22.12.2012

#16

03.06.2013 11:32:43

В теме

http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=25457

есть файл

http://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=40202&action=download

Там есть такой код:

Код

    For Each aFolder In fso.GetFolder(ThisWorkbook.Path).Files
    
        For Each aFile In aFolder.Files
        
            If fso.GetExtensionName(aFile.Name) Like "xls*" Then
            
                Set wkb = Workbooks.Open(aFile.Path)
                Set wks = wkb.Worksheets(1)
                With wks

и т.д.
Думаю, можно использовать.

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	что-то я не могу разобраться совсем

anvg

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

Пробуйте, первый запуск будет долгим. Далее быстрее. Если есть подозрение, что файлы в папке и подпапках изменили положение или имя, то нажать «Обновить». Путь к начальной папке задаётся константой baseFolder в методе InitializeFindю
Успехов.

lenok

Пользователь

Сообщений: 39
Регистрация: 23.05.2013

#19

04.06.2013 07:29:04

Код
Const baseFolder = "d:project"

я так понимаю, здесь надо прописать адрес самой папки, это понятно…
а имя файла он где будет брать???

anvg

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#20

04.06.2013 07:50:49

Цитата
а имя файла он где будет брать???

Из активной ячейки (в ней только имя, без расширения)

Изменено: anvg — 04.06.2013 07:52:42

lenok

Пользователь

Сообщений: 39
Регистрация: 23.05.2013

#21

04.06.2013 08:07:46

все, поняла….. все работает…спасибо большое…. и еще один вопрос, если можно….:
как это все сделать так, чтобы он был без этих кнопочек, а в таком виде, чтобы автоматически включался???

до этого было прописано так, но он только с одной папки так открывает….
Заранее огромное спасибо вам!!!!!!!!

Код

Sub ARM()
    Dim f As String, folder As String, file_name As String
    'Папка для поиска
    folder = "C:Documents and SettingsmaksРабочий столДокументы"
    'Ячейка с именем файла
    file_name = LCase(Range("D1")) & ".xls"
    f = Dir(folder)
    While Not Len(f) = 0
        If LCase(f) = file_name Then

            Workbooks.Open folder & f
           
 Application.Run "ARM.XLS!ARM6"
            Exit Sub
        End If
        f = Dir()
    Wend

    Application.Run "ARM.XLS!ARM4"
End Sub

Изменено: lenok — 04.06.2013 23:58:03

KuklP

Пользователь

Сообщений: 14868
Регистрация: 21.12.2012

E-mail и реквизиты в профиле.

#22

04.06.2013 08:24:36

А на кой тут цикл? Если имя файла известно, зачем перебирать все файлы?

Код

Sub ARM()
    Dim folder As String, file_name As String
    'Папка для поиска
    folder = "C:Documents and SettingsmaksРабочий столДокументы"
    'Ячейка с именем файла
    file_name = LCase(Range("D1")) & ".xls"
    If Len(Dir(folder & file_name)) Then
        Workbooks.Open folder & file_name
        Application.Run "ARM.XLS!ARM6"
        Exit Sub
    End If
    Application.Run "ARM.XLS!ARM4"
End Sub

Я сам — дурнее всякого примера! …

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	он не открывает тогда файл в поддиректории

KuklP Пользователь Сообщений: 14868 Регистрация: 21.12.2012 E-mail и реквизиты в профиле.	Ага. А с циклом, следовательно, открывает? Я сам — дурнее всякого примера! …

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013	неа… тоже не открывает…. а надо, чтобы открывал… там мне уже без разницы, есть цикл или нет… надо, чтобы он поддиректории просматривал

anvg

Пользователь

Сообщений: 11878
Регистрация: 22.12.2012

Excel 2016, 365

#26

04.06.2013 09:43:56

Скрытый текст

lenok Пользователь Сообщений: 39 Регистрация: 23.05.2013

Sandero

Пользователь

Сообщений: 14
Регистрация: 27.02.2014

#28

18.06.2019 13:20:28

Цитата

Hugo написал:
Я чего-то не понимаю?Если есть имя файла — то зачем искать? Взяли и открыли. Если ошибка — обработали.А искать может быть долго — если например файлов тысячи. Да и код с таким поиском больно длинный — хватает ведь 3-х строк

Добрый день!
Попробовал ваш вариант, работает. Я правда добавил ещё запуск другого макроса по созданию файла с этим именем если его нет (т.е. если не выполнено первое условие)
Эксель при отсутствии файла выдаёт своё собственное сообщение
По нажатии «оК» появляется уже месседж из макроса.
М.б. это связано с версией экселя, у меня 2016, а тут код вроде для 2003 изначально, или это не имеет значения.
Можно ли убрать сообщение самого экселя?
Заранее благодарен!!

Код

Sub SearhFiles() 'Макрос поиска файла с именем и автоматическое его открытие при наличии
On Error GoTo err_: Workbooks.Open "\Server777S" & Range("F2") & ".xls": Exit Sub
err_:     MsgBox "Нет такого файла!"
Application.Run "DOC.xlsm!Upload" 'Запуск макроса по созданию файла с именем
End Sub

Источник

Sub test()

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir("thesentence") <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

In this when i pickup the text value from the input box, it doesn’t work. If however, if remove "the sentence" from If Dir() and replace it with an actual name in the code, it works. Can somebody help?

asked Jul 20, 2012 at 6:25

Note your code contains Dir("thesentence") which should be Dir(thesentence).

Change your code to this

Sub test()

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir(thesentence) <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

answered Jul 20, 2012 at 6:31

CylianCylian

10.8k4 gold badges43 silver badges55 bronze badges

Use the Office FileDialog object to have the user pick a file from the filesystem. Add a reference in your VB project or in the VBA editor to Microsoft Office Library and look in the help. This is much better than having people enter full paths.

Here is an example using msoFileDialogFilePicker to allow the user to choose multiple files. You could also use msoFileDialogOpen.

'Note: this is Excel VBA code
Public Sub LogReader()
    Dim Pos As Long
    Dim Dialog As Office.FileDialog
    Set Dialog = Application.FileDialog(msoFileDialogFilePicker)

    With Dialog
        .AllowMultiSelect = True
        .ButtonName = "C&onvert"
        .Filters.Clear
        .Filters.Add "Log Files", "*.log", 1
        .Title = "Convert Logs to Excel Files"
        .InitialFileName = "C:InitialPath"
        .InitialView = msoFileDialogViewList

        If .Show Then
            For Pos = 1 To .SelectedItems.Count
                LogRead .SelectedItems.Item(Pos) ' process each file
            Next
        End If
    End With
End Sub

There are lots of options, so you’ll need to see the full help files to understand all that is possible. You could start with Office 2007 FileDialog object (of course, you’ll need to find the correct help for the version you’re using).

answered Jul 20, 2012 at 7:19

ErikEErikE

48.4k23 gold badges150 silver badges194 bronze badges

Correction to fileExists from @UberNubIsTrue :

Function fileExists(s_directory As String, s_fileName As String) As Boolean

  Dim obj_fso As Object, obj_dir As Object, obj_file As Object
  Dim ret As Boolean
   Set obj_fso = CreateObject("Scripting.FileSystemObject")
   Set obj_dir = obj_fso.GetFolder(s_directory)
   ret = False
   For Each obj_file In obj_dir.Files
     If obj_fso.fileExists(s_directory & "" & s_fileName) = True Then
        ret = True
        Exit For
      End If
   Next

   Set obj_fso = Nothing
   Set obj_dir = Nothing
   fileExists = ret

 End Function

EDIT: shortened version

' Check if a file exists
Function fileExists(s_directory As String, s_fileName As String) As Boolean

    Dim obj_fso As Object

    Set obj_fso = CreateObject("Scripting.FileSystemObject")
    fileExists = obj_fso.fileExists(s_directory & "" & s_fileName)

End Function

answered May 29, 2013 at 19:14

amackay11amackay11

7191 gold badge10 silver badges17 bronze badges

just get rid of those speech marks

Sub test()

Dim thesentence As String

thesentence = InputBox("Type the filename with full extension", "Raw Data File")

Range("A1").Value = thesentence

If Dir(thesentence) <> "" Then
    MsgBox "File exists."
Else
    MsgBox "File doesn't exist."
End If

End Sub

This is the one I like:

Option Explicit

Enum IsFileOpenStatus
    ExistsAndClosedOrReadOnly = 0
    ExistsAndOpenSoBlocked = 1
    NotExists = 2
End Enum


Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus

With New FileSystemObject
    If Not .FileExists(FileName) Then
        IsFileReadOnlyOpen = 2  '  NotExists = 2
        Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
    End If
End With

Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
On Error GoTo 0

Select Case iErr
    Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
    Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
    Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select

End Function    'IsFileReadOnlyOpen

answered Jul 21, 2012 at 13:52

whytheqwhytheq

34k64 gold badges170 silver badges265 bronze badges

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

Works very well, almost, at my site. If I call it with «» the empty string, Dir returns «connection.odc«!! Would be great if you guys could share your result.

Anyway, I do like this:

Function FileExists(fullFileName As String) As Boolean
  If fullFileName = "" Then
    FileExists = False
  Else
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
  End If
End Function

answered Oct 22, 2015 at 11:12

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

answered Jun 14, 2015 at 2:09

Ronnie RoystonRonnie Royston

16k6 gold badges73 silver badges88 bronze badges

I’m not certain what’s wrong with your code specifically, but I use this function I found online (URL in the comments) for checking if a file exists:

Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean
    'Code from internet: http://vbadud.blogspot.com/2007/04/vba-function-to-check-file-existence.html
    'Returns True if the passed sPathName exist
    'Otherwise returns False
    On Error Resume Next
    If sPathName <> "" Then

        If IsMissing(Directory) Or Directory = False Then

            File_Exists = (Dir$(sPathName) <> "")
        Else

            File_Exists = (Dir$(sPathName, vbDirectory) <> "")
        End If

    End If
End Function

answered Jul 20, 2012 at 6:31

DanDan

44.9k17 gold badges88 silver badges157 bronze badges

Very old post, but since it helped me after I made some modifications, I thought I’d share. If you’re checking to see if a directory exists, you’ll want to add the vbDirectory argument to the Dir function, otherwise you’ll return 0 each time. (Edit: this was in response to Roy’s answer, but I accidentally made it a regular answer.)

Private Function FileExists(fullFileName As String) As Boolean
    FileExists = Len(Dir(fullFileName, vbDirectory)) > 0
End Function

answered Dec 19, 2018 at 3:55

based on other answers here I’d like to share my one-liners that should work for dirs and files:

Len(Dir(path)) > 0 or Or Len(Dir(path, vbDirectory)) > 0  'version 1 - ... <> "" should be more inefficient generally

(just Len(Dir(path)) did not work for directories (Excel 2010 / Win7))

CreateObject("Scripting.FileSystemObject").FileExists(path)  'version 2 - could be faster sometimes, but only works for files (tested on Excel 2010/Win7)

as PathExists(path) function:

Public Function PathExists(path As String) As Boolean
    PathExists = Len(Dir(path)) > 0 Or Len(Dir(path, vbDirectory)) > 0
End Function

answered Aug 12, 2019 at 9:21

Andreas CovidiotAndreas Covidiot

4,1785 gold badges50 silver badges95 bronze badges

Источник

Добрый день! Подскажите пожалуйста, где я ошибаюсь. Задача следующаяя: имеются файлы, которые эксель определяет. В этих файлах хранится текстовая информация. В главном файле задается критерий для поиска и кноркой активируется поиск, после чего найденные записи по всем файлам выводятся на лист главного. Но при поиске он ищет почему-то только в самом себе, а не в нужных.

200?’200px’:»+(this.scrollHeight+5)+’px’);»>
Private Sub CommandButton1_Click()
ТекстДляПоиска = «ант»
[c1] = «C:UsersАдминистраторDesktopГУН»
‘ Ищем файлы в заданной папке по заданной маске,
‘ и выводим на лист список их параметров.
‘ Просматриваются папки с заданной глубиной вложения.

Dim coll As Collection, FolderPath$, searchmask$, searchdepth%
On Error Resume Next
FolderPath$ = [c1] ‘ берм из ячейки c1
searchmask$ = «*.*xl*» ‘ берм из ячейки c2
searchdepth% = 1 ‘ берм из ячейки c3
If searchdepth% = 0 Then searchdepth% = 999 ‘ без ограничения по глубине

‘ считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(FolderPath$, searchmask$, searchdepth%)

Application.ScreenUpdating = False ‘ отключаем обновление экрана

‘ выводим результаты (список файлов, и их характеристик) на лист
For i = 1 To coll.Count ‘ перебираем все элементы коллекции, содержащей пути к файлам

filenumber = i
pathtothefile = coll(i)
Filename = Dir(pathtothefile)
creationdate = FileDateTime(pathtothefile)
filesize = FileLen(pathtothefile)
filesize = FileOrFolderSize(filesize)
‘——————————————————————
ТекстДляПоиска = «*» & «ант» & «*»
Set СписокНомеровНайденныхСтрок = New Collection
On Error Resume Next ‘ отключаем останов при ошибке

Workbooks.Open Filename:=pathtothefile
Workbooks(pathtothefile).Activate
With ThisWorkbook.Worksheets(«Лист1»)
‘——————————————————————
ПоследняяСтрокаБД = .Range(«a» & .Rows.Count).End(xlUp).Row ‘ вычисляем номер последней строки
Dim РезультатПоиска As Range, АдресПервойНайденнойЯчейки As String

Set РезультатПоиска = Cells.Find(ТекстДляПоиска, LookAt:=xlPart) ‘ начинаем поиск

If Not РезультатПоиска Is Nothing Then ‘ если нашли хоть одну подходящую ячейку
АдресПервойНайденнойЯчейки = РезультатПоиска.Address ‘ запоминаем Адрес Первой Найденной Ячейки
НомерСтроки = РезультатПоиска.Row ‘ получаем номер строки, в которой найдена подходящая ячейка
СписокНомеровНайденныхСтрок.Add НомерСтроки, CStr(НомерСтроки) ‘ записываем номер строки в список
Do
‘ ищем следующую ячейку
Set РезультатПоиска = Cells.FindNext(РезультатПоиска)

If Not РезультатПоиска Is Nothing Then ‘ если нашли очередную подходящую ячейку
НомерСтроки = РезультатПоиска.Row ‘ получаем номер строки, в которой найдена подходящая ячейка
СписокНомеровНайденныхСтрок.Add НомерСтроки, CStr(НомерСтроки) ‘ записываем номер строки в список
End If

‘ повторяем поиск до тех пор, пока не дойдм до Первой Найденной Ячейки
Loop While РезультатПоиска.Address <> АдресПервойНайденнойЯчейки
End If
‘——————————————————————
End With
ActiveWorkbook.Close False

On Error GoTo 0 ‘ отключение режима пропуска ошибок
‘——————————————————————
Range(«a» & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
Array(filenumber, Filename, pathtothefile, creationdate, filesize)

‘ если нужна гиперссылка на файл во втором столбце
ActiveSheet.Hyperlinks.Add Range(«b» & Rows.Count).End(xlUp), pathtothefile, «», _
«Открыть файл» & vbNewLine & Filename

On Error GoTo 0

Range(«a:e»).EntireColumn.AutoFit ‘ автоподбор ширины столбцов
End Sub

Заранее благодарен. Просьба не судить за русскоязычные переменные, знаю что это не правильно.
[moder]Оформите код тегами (кнопка #)[/moder]

‘ считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(FolderPath$, searchmask$, searchdepth%)

Application.ScreenUpdating = False ‘ отключаем обновление экрана

Set РезультатПоиска = Cells.Find(ТекстДляПоиска, LookAt:=xlPart) ‘ начинаем поиск

On Error GoTo 0

Range(«a:e»).EntireColumn.AutoFit ‘ автоподбор ширины столбцов
End Sub

Заранее благодарен. Просьба не судить за русскоязычные переменные, знаю что это не правильно.
[moder]Оформите код тегами (кнопка #)[/moder] scofield

Сообщение Добрый день! Подскажите пожалуйста, где я ошибаюсь. Задача следующаяя: имеются файлы, которые эксель определяет. В этих файлах хранится текстовая информация. В главном файле задается критерий для поиска и кноркой активируется поиск, после чего найденные записи по всем файлам выводятся на лист главного. Но при поиске он ищет почему-то только в самом себе, а не в нужных.

‘ считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(FolderPath$, searchmask$, searchdepth%)

Application.ScreenUpdating = False ‘ отключаем обновление экрана

Set РезультатПоиска = Cells.Find(ТекстДляПоиска, LookAt:=xlPart) ‘ начинаем поиск

On Error GoTo 0

Range(«a:e»).EntireColumn.AutoFit ‘ автоподбор ширины столбцов
End Sub

Заранее благодарен. Просьба не судить за русскоязычные переменные, знаю что это не правильно.
[moder]Оформите код тегами (кнопка #)[/moder] Автор — scofield
Дата добавления — 28.09.2015 в 11:29

Источник

Получение списка файлов в папке и подпапках средствами VBA

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

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

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

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

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

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

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

‘ Пример использования функции в макросе:

Этот код позволяет осуществить поиск нужных файлов в выбранной папке (включая подпапки), и выводит полученный список файлов на лист книги Excel:

Ещё один пример использования:

PS: Найти подходящие имена файлов в коллекции можно при помощи следующей функции:

Не знаю что там за проблема с некорректными именами файлов, — я этот код использовал в сотнях макросов, эта функция работает в составе моих надстроек на десятках тысяч компьютеров, и никаких проблем не наблюдается.
И ни разу я не применял имена MS DOS..

Игорь, спасибо за рабочий пример (немного докрутил и использую в работе).
Что касается вопроса с некорректными именами файлов (которые не любит обрабатывать сей код (например, если в имени есть символ из непонятной кодировки)), выход нашел немного «топорный»: внутри обработки применяю имена MS DOS, которые обрабатываются нормально в большинстве случаев, а в интерфейсе делаю подмену имен на виндовые. Возможно не совсем понятно написал, но примера сейчас нет под рукой.

Спасибо автору, хороший код для поиска файлов, но возникает вопрос, а можно отключить отображение поиска внизу экселя?

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

Александр, нет таких полей у файлов произвольного формата, — потому, никак.

Посоветуйте пожалуйста как с помощью FSO получить доступ к полям Теги и Комментарии. Спасибо Alexander A. Rylov

Михаил, найдите в верхней части кода строку Option Explicit
и удалите её (эта строка требует объявлять переменные)

Подскажите. Почему excel может ругаться на
Set FSO = CreateObject(«Scripting.FileSystemObject») ‘ создаём экземпляр FileSystemObject
Пишет что переменная не объявлена/не определена

Нужно выше дописать
Dim FSO As Object?
Или в настройках excel 2016 что-то не так? Притом ругается на все не объявленные переменные.
А переменные типа Filename$ вообще не воспринимает как переменные. В чем может быть дело?
Гуглинг пока не помог.

Здравствуйте.
DoEvents никак не влияет на правильность работы (и не может повлиять)
А количество активных гиперссылок на листе Excel ограничено, — никак не сделать, чтобы на одном листе было более 50 или 65 тысяч АКТИВНЫХ гиперссылок.

Доброго времени суток. Огромное спасибо за программу!

Добавлю от себя и задам вопрос.

При использовании «DoEvents» программа может не правильно работать, в том числе выводить не все значения. Я ее закомментировал.

При привышении 65532 строк гиперссылки прекращают формироваться. Как можно победить?

Здравствуйте.
Под заказ что угодно могу сделать (платно)

Здравствуйте. Для примера из файла «FilenamesCollectionEx.xls» — можете сделать, чтобы выводимый на лист Excel список файлов был отсортирован по размеру(по уменьшению)?

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

Здравствуйте! Меня тоже интересует макрос по поиску файлов. Можете сделать так что бы в ячейках к примеру A1 задать имя файла, A2 задать тип файла и A3 путь к папке?

Огромное Вам спасибо! Столько времени мне съэкономили.
СПА-СИ-БО! 🙂

Спасибо. Очень полезная вещь!

Здравствуйте, Юрий
Да, это можно исправить, — другой код нужен
(встроенные в VBA функции иногда дают ошибки)

Добрый день
В случае если в именах файлов встречаются нестандартные символы (допустимые в Win) макрос выдает ошибку
Ошибка в строке ДатаСоздания = FileDateTime(ПутьКФайлу)
Можно добавить onError Resume Next но это пропуск ошибки будет а размер файла не будет определен. Есть ли варианты сделать определение размера файлов и для таких файлов тоже?

Пример папки на которой сканирование папки «спотыкается»: https://bit.ly/2zz8Tfw

Игорь, подскажите, а можно ли в файл FilenamesCollectionEx.xls добавить маску имени подпапки, в которой производить поиск? Ситуация: файл с одинаковм именем может лежать в подпапках с разными именами. Я точно знаю, что нужная мне версия должна лежать в определенной подпапке. И проверять таким образом только их?

Так вроде и то и другое выводится
Код открыт ведь, — поменяйте как вам надо, если лишний столбец мешает.

Возможно я слепой или плохо читаю, но я не увидел что-то подобное в коментах. Поэтому мой вопрос следующий: можно как-то сделать так, чтобы выводило только название файла а не весь путь?

Отбой, разобрался. Виноват оказался не этот макрос, а тот, который его результаты использовал. Мораль — люди, не юзайте Dir, если вам нужно что-то сделать с папкой, к которой он обращается.

В моём макросе нет MoveFolder — так что мой макрос точно не виноват в вашей проблеме.
Проблема — либо в неверном использовании MoveFolder (не то или не туда перемещаете), либо нет прав доступа на перемещение в заданное место.

Игорь, всё это прекрасно. Непонятно только, что нужно сделать с Вашим макросом, чтобы после его вызова с папкой можно было бы ещё и что-нибудь сделать, например, переместить. Сейчас после вызова FSO.MoveFolder вылетает с ошибкой Access denied. Проверено, виноват именно Ваш макрос — если закомментировать ТОЛЬКО его вызов, FSO.MoveFolder отрабатывает нормально.

Спасибо, ОГРОМНОЕ.
Выручайте ребята! макрос в целом отличный, но для моих целе нужно немного переделать.
Нужно чтоб все файлы находящиеся в каждой папке были в одной ячейке через разделитель ( | )
Например:
C:images4-20161032g.jpg|C:images4-20161033g.jpg|C:images4-20161033g.jpg

Да, сделал.
Высылайте на почту подробное задание (что и как должно выглядеть, для чего это вообще нужно, и т.д.)
Тогда озвучу сроки и стоимость

Добрый день!
Скажите, пожалуйста, сделали ли вы макрос для Александра?
Если да, то за сколько его можно приобрести?
Если нет, то какие сроки выполнения?
Спасибо!

Напишите на почту стоимость и сроки выполнения

Александр, в этом случае нужен более сложный макрос.
Могу сделать под заказ.

Здравствуйте, Макрос хороший. Всё отлично выводит. Но как сделать дерево? Имеется несколько папок, далее нажимаешь на папку или плюс или еще что-то, она открывается, появляется подпапки, опять жмешь на подпапку появляются подпапки и т.д.

Спасибо, отличный макрос

В ответ на:
Андрей, 15 Мар 2018 — 15:13.#3
Добрый день.
файл 148 знаков (рус.буквы) не обрабатывается,
и сам файл на сервере (если файл на раб.столе то все работает)
какая максимальная длина имени и можно-ли ее обойти.

Ограничение на полное имя файла, включая расширение — 259 символов. Соответственно, все файлы, имеющие более длинное имя при выполнении
Set curfold = FSO.GetFolder(FolderPath)
будут проигнорированы. Тестировал на EX2010, W7 и MSServer 2008. У меня из 28 (curfold.Соunt) файлов реально в коллекции только 15 (curfold.items(1). curfold.items(15))

А как сделать макрос чтобы он мне показал только пустые папки?

Ограничений по длине имени файла, вроде как, нет (по крайней мере, за много лет использования этого кода на тысячах компов, с проблемами не сталкивался)

Добрый день.
файл 148 знаков (рус.буквы) не обрабатывается,
и сам файл на сервере (если файл на раб.столе то все работает)
какая максимальная длина имени и можно-ли ее обойти.

Адаптировал к access — все работает, спасибо, очень помогло

Ринат, посмотрите макрос обработки файлов из папки.
Там выводится диалоговое окно папки, и обрабатываются все файлы в ней (независимо от имён файлов)

Добрый день!
Такой вопрос, в отделе каждый месяц сотрудник ведет отчет по своей работе в табличной форме в ексель каждый в своем файле, а начальству необходимо данные отчеты ввести в свою итоговую таблицу для себя, то есть скопировать данные отчетов с файлов каждого сотрудника в свой отдельный файл. Я создал макрос, для скопирования данных с файлов каждого сотрудника в таблицу файла начальству указывая путь к каждому файлу. Но при этом возникает определенные неудобства, каждый месяц нужно пути к файлам прописывать заново, так как на следующий месяц создаются новые файлы по отчетам, и пути к ним необходимо обновлять. Подскажите пожалуйста, как можно сделать так, чтоб пути к файлам привязывались не по конкретному расположению файла, а например указыванием месяца и года можно было сформировать единый отчет на определенный месяц. Спасибо заранее!

Большое спасибо автору! Список использую для каталогизации архива сканов документов.

Да, можем сделать такой макрос под заказ.
Минимальная стоимость заказа 1500 руб.

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

или например на основе Вашего FilenamesCollectionEx.xls нашел все файлы на диске/папке нужные -нажимаешь на файл и ты нужен выбрать ячейку куда вписать имя файла
заранее спасибо

У меня почему-то размер файла в байтах выводится абсолютно иной, иногда даже с отрицательным значением.
Пример:
1.вес файла 3 840 327 Кб или 3,66 Гб, а таблица выдает «-362 472 675»
2.вес файла 5 082 087 Кб или 4,84 Гб, таблица выдает «909 089 137»

Василий, да, можно добавить.
Пример код можете здесь посмотреть:
http://excelvba.ru/code/MCI

Добрый день! Подскажите, возможно ли добавить столбцы «продолжительность» и «ширина кадра», которые имеются в данных файлов?

Здравствуйте, Елизавета.
Причин может быть несколько, навскидку:
— проблемный файл, или файл, к которому у вас нет доступа (ошибка 53 — файл не найден)
— слишком длинное имя папки (много уровней вложенности) и/или файла
— сбой в файловой системе
— ошибка в макросе (что-то в коде не учтено)

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

Игорь, огромное вам спасибо за эту работу!
Несколько лет использую ваш файл для классификации фильмов, но пару недель назад почему-то он перестал работать. Никакой критичности в этом нет, т.к. главное исправила благодаря обсуждениям тут, но мне непонятно и жутко интересно, почему так происходит. Может, это связано с активацией офиса(примерно в то же время было)? Офис 10й.
У меня 2 вкладки в этом файле, обновляю список на 2й, и затем новые позиции копирую в первую (накапливаю). При обновлении списка, после 60-70 позиций, макрос останавливается и сообщает об ошибке Run-time error 53 со сслыкой на строку ДатаСоздания = FileDateTime(ПутьКФайлу). Дело не файле, т.к. его удаление не помогло. Я добавила в скрипт «On Error Resume Next», список обновляется до конца, но перестают запускаться фильмы по гиперссылке в 1й вкладке «не удается открыть указанный файл» (во 2й работают), хотя файл и макросы одни и те же. Знаете, в чем может быть причина?

Источник

Adblock
detector

Источник

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

Пример в файле 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
    ' © 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

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

301791 просмотр

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

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

Источник

0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

Поиск файла в папке по тексту из ячейки книги

05.05.2013, 16:53. Показов 17649. Ответов 5

Добрый день форумчане. Прошу помощи у Вас.
Задача следующая:
Есть папка на диске С, в ней файлы xls. В ячейке L1 рабочей книги находится текст который является частью названия файлов в папке на диске С (например «сводка» или «Отчет»). Нужен код vba который смог бы пересмотреть эти файлы в папке, отобрать те в названии которых присутсвует текст из ячейки L1, полные названия вписать в строки в рабочей книги, и из этого списка выбрать файл с последней датой создания.
Жду Ваших ответов.

Alex77755

11482 / 3773 / 677

Регистрация: 13.02.2009

Сообщений: 11,145

05.05.2013, 20:24

Для начала:

Visual Basic

  'Показываем диалог выбора папки 
  With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Выберите папку, файлы в которой нужно обработать" 
    .ButtonName = "Выбрать" 
    .AllowMultiSelect = False 
    If .Show Then Folder = .SelectedItems(1) Else Exit Sub 
  End With 
  'Начинаем читать файлы из папки 
  wb = Dir(Folder & Application.PathSeparator & "*.xls") ' здесь выбираются екселовские файлы
' модифицируйте под свои условия
  While Len(wb) > 0 ' если такой файл есть
'здесь добавить код проверки даты создания
 
    wb = Dir 'читаем следующий файл 
  Wend

Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

06.05.2013, 00:38

Сообщение от stogs

Нужен код vba который смог бы пересмотреть эти файлы в папке

Включая подпапки или нет?

Добавлено через 3 часа 28 минут
Так можно получить список файлов в указанной папке без подпапок, отсортированный по возрастанию даты, т.е. последний — самый свежий. Если желаете в обратном порядке — измените /o:d на /o:-d в параметрах dir.

Visual Basic

Sub bb()
Dim fldr$, v
fldr = "C:Temp" 'папка, в которой искать файлы
With CreateObject("ADODB.Stream")
    .Type = 2 'adTypeText
    .Open
    .Charset = "Windows-1251"
'При передаче текстовых данных в VBA из не-Unicode источников в русском Windows
'используется эта кодировка (что в данном случае неправильно).
'Если назначить объекту ADODB.Stream эту кодировку, текст в нем будет перекодирован обратно.
    .WriteText CreateObject("wscript.shell").Exec("cmd /c dir /b/o:d """ & fldr & "*" & [L1] & "*.xls*""").StdOut.ReadAll
    .Position = 0
    .Charset = "cp866"
'А теперь назначили объекту ADODB.Stream правильную кодировку, которая будет использована
'в методе .ReadText для перекодирования в Unicode.
    v = Application.Transpose(Split(.ReadText, vbCrLf))
End With
[a1].Resize(UBound(v)).Value = v 'выгрузка списка файлов начиная с яч. А1
End Sub

0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

06.05.2013, 15:52

[ТС]

Спасибо огромное, это именно то что мне нужно.

0 / 0 / 0

Регистрация: 05.05.2013

Сообщений: 57

14.05.2013, 14:32

[ТС]

Доброго времени суток. Как то я сразу не подумал, и вот возникла в данном случае очередная проблема. Связана она с тем, что если вдруг в папке ктонибудь открывает старый файл и закрывает его потом с сохранением изменений, макросом потом этот файл воспринимается как самый свежий. Это не допустимо. Есть возможность сохранять файлы с датой, напимер «счет 12.05.2013». в таком случае необходима сортитовка по дате в названии файла. Как это сделать?
Жду Ваших ответов.

undefined7

259 / 7 / 1

Регистрация: 22.01.2013

Сообщений: 47

14.05.2013, 14:58

Сообщение от stogs

Вот 2 макроса, первый — создаёт лист и в нём записывает все файлы которые есть в текущей книги, можно соаздавать такой лист, а потом оттуда отсортировать и открыть нужный

Visual Basic

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
    Sheets("FileList").Select
    Worksheets("FileList").Range("A1:E" & Range("A65536").End(xlUp).Row).ClearContents
    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

Visual Basic

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
    Dim X As Variant
    
    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
'        On Error Resume Next
    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

Источник