Пычев Анатолий

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