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 ' очистка строки состояния 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 LoopThroughFiles(ByVal sDirName As String, ByRef lRow As Long, ByVal sMask As String)
On Error Resume Next
Dim folder$, coll As Collection
Dim EX As Excel.Application
Dim wkb As Workbook
Dim wks As Worksheet
Dim file As Variant
Dim i As Long
Dim v As Variant
folder$ = sDirName
If Dir(folder$, vbDirectory) = "" Then
MsgBox "Не найдена папка «" & folder$ & "»", vbCritical
Exit Sub ' выход, если папка не найдена
End If
Set coll = FilenamesCollection(folder$, sMask) ' получаем список файлов по маске из папки
If coll.Count = 0 Then
' MsgBox "В папке «" & Split(folder$, "\")(UBound(Split(folder$, "\")) - 1) & "» нет ни одного подходящего файла!", _
vbCritical, "Файлы для обработки не найдены"
Exit Sub ' выход, если нет файлов
End If
Set EX = New Application
EX.Visible = False
' перебираем все найденные файлы
For Each file In coll
Cells(lRow, 2) = CStr(file)
Set wkb = EX.Workbooks.Open(Filename:=file)
' Если книга не пуста
If wkb.Sheets.Count > 0 Then
i = 1
ReDim v(1 To wkb.Sheets.Count)
' Получаем названия листов
For Each wks In wkb.Sheets
v(i) = wks.Name
i = i + 1
Next wks
End If
Cells(lRow, 3) = Join(v, ",")
wkb.Close False
DoEvents
lRow = lRow + 1
DoEvents
Next file
Set wks = Nothing: Set wkb = Nothing: Set EX = Nothing
Set colShts = Nothing
End Sub
Sub LoopThroughDirs()
Dim lLastRow As Long
Dim lRow As Long
Dim i As Long
Dim v As Variant
Dim dTime As Double
lRow = 2
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
v = Range(Cells(2, 1), Cells(lLastRow, 2))
dTime = Time()
For i = LBound(v) To UBound(v)
Application.StatusBar = "Обрабатывается директория " & i & " из " & UBound(v)
Call LoopThroughFiles(v(i, 1), lRow, "*.xls")
Call LoopThroughFiles(v(i, 1), lRow, "*.xlsx")
Call LoopThroughFiles(v(i, 1), lRow, "*.xlsm")
DoEvents
Next i
MsgBox "Готово за " & CStr(CDate(Time() - dTime))
End Sub
Сложный
