Sub ЗагрузкаСпискаФайлов()
' Ищем файлы в заданной папке по заданной маске,
' и выводим на лист список их параметров.
' Просматриваются папки с заданной глубиной вложения.
Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%
ПутьКПапке$ = "C:\1\Сканированное" ' берём из ячейки c1
МаскаПоиска$ = "txt" ' берём из ячейки c2
ГлубинаПоиска% = Val(1) ' берём из ячейки c3
' считываем в колекцию 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(, 2).Value = _
Array(ИмяФайла, ДатаСоздания)
' если нужна гиперссылка на файл во втором столбце
ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
"Открыть файл" & vbNewLine & ИмяФайла
DoEvents ' временно передаём управление ОС
Next
End Sub
Sub ОчисткаСписка()
Worksheets("FileList").Range("B2:D2" & Range("A65536").End(xlUp).Row).ClearContents
End Sub
' ===================== код функции ===========================
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