Отчет по множеству файлов

Dim FSO As Object
Dim FAdr As String
Const MnDir As String = "C:\Пример_112\"
Sub test()
    Dim con As Object, rst As Object, cell As Range
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set con = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    For Each cell In Range("A1:A" & Sheets(1).Cells(Sheets(1).Rows.Count, 1).End(xlUp).Row)
        SearchFile MnDir, Int(cell.Value) & ".xlsx"
        If FAdr <> "" Then
            con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & FAdr & "; Extended Properties=""Excel 12.0;HDR=No;IMEX=1""")
            rst.Open ("SELECT * From [Лист1$F54:F54]"), con
            cell.Offset(, 1).Value = rst.Fields("F1")
            rst.Close
        
            rst.Open ("SELECT * From [Лист1$H83:H83]"), con
            cell.Offset(, 2).Value = rst.Fields("F1")
            rst.Close
        
            rst.Open ("SELECT * From [Лист1$A5:A5]"), con
            cell.Offset(, 3).Value = rst.Fields("F1")
            rst.Close
        
            FAdr = ""
            con.Close
        End If
    Next cell
    Set FSO = Nothing
    Set rst = Nothing
    Set con = Nothing
End Sub
 
Sub SearchFile(dirname As String, FName As String)
    Dim nm
    For Each nm In FSO.GetFolder(dirname).SubFolders
        If FSO.FileExists(nm.Path & "\" & FName) Then
            FAdr = nm.Path & "\" & FName
            Exit For
        End If
        SearchFile nm.Path, FName
    Next nm
End Sub

Dim FCol As New Collection
Dim FSO As Object
Dim FAdr As String
Const MnDir As String = "C:\Пример_112\"
Sub test()
    Dim con As Object, rst As Object, i As Integer, Mas()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set FCol = Nothing
    Col (MnDir)
    Set con = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    Mas = Range("A1:D" & Sheets(1).Cells(Sheets(1).Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(Mas, 1) To UBound(Mas, 1)
        On Error Resume Next
        FAdr = FCol(Int(Mas(i, 1)) & ".xlsx")
        If Err = 0 Then
            con.Open ("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & FAdr & "; Extended Properties=""Excel 12.0;HDR=No;IMEX=1""")
            rst.Open ("SELECT * From [Лист1$F54:F54]"), con
            Mas(i, 2) = rst.Fields("F1")
            rst.Close
            rst.Open ("SELECT * From [Лист1$H83:H83]"), con
            Mas(i, 3) = rst.Fields("F1")
            rst.Close
            rst.Open ("SELECT * From [Лист1$A5:A5]"), con
            Mas(i, 4) = rst.Fields("F1")
            rst.Close
            con.Close
          Else
            Err = 0
        End If
    Next i
    Range("A1:D" & Sheets(1).Cells(Sheets(1).Rows.Count, 1).End(xlUp).Row).Value = Mas
    Set FCol = Nothing
    Set FSO = Nothing
    Set rst = Nothing
    Set con = Nothing
End Sub
 
Sub Col(dirname As String)
    Dim nm, fil
    For Each nm In FSO.GetFolder(dirname).SubFolders
        For Each fil In nm.Files
            FCol.Add nm.Path & "\" & fil.Name, fil.Name
        Next fil
        Col nm.Path
    Next nm
End Sub

Private Declare Function SearchTreeForFile _
        Lib "imagehlp.dll" ( _
        ByVal RootPath As String, _
        ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
 
Private Sub Test()
    With Application
         .ScreenUpdating = False
         .DisplayAlerts = False
         .Calculation = xlManual
    End With
   
    Dim iSource As Range, iCell As Range
    Dim iPath$, iFileName1$, iFileName2$, iAddress$, iCount%
    
    iPath = ThisWorkbook.Path 'Можно указать 'родительскую' папку самостоятельно
    
    With ThisWorkbook.Worksheets(1)
         Set iSource = .Range(.Cells(1, "A"), .Cells(1, "A").End(xlDown))
    End With
         
    For Each iCell In iSource
        iFileName1 = iCell & ".xlsx": iFileName2 = Space(255)
        
        If SearchTreeForFile(iPath, iFileName1, iFileName2) <> 0 Then
        
           iFileName2 = Application.Trim(iFileName2)
           iFileName2 = Replace(iFileName2, iFileName1, "[" & iFileName1 & "]", , , vbTextCompare)
           
           For iCount = 1 To 3
               iAddress = Choose(iCount, "F54", "H83", "A5")
               With iCell.Offset(, iCount)
                    .Formula = "='" & iFileName2 & "Лист1'!" & iAddress
                    .Value = .Value
                    'Возможно имеет смысл заменять формулы на значения, либо
                    'сразу в трёх ячейках строки, либо вообще во 'всём' диапазоне
               End With
           Next
           
        Else
           iCell.Offset(, 1).Resize(, 3) = CVErr(xlErrNA) '#Н/Д
        End If
    Next
   
    With Application
         .Calculation = xlAutomatic
         .DisplayAlerts = True
         .ScreenUpdating = True
    End With
End Sub

 FCol.Add nm.Path & "\" & fil.Name, fil.Name

On Error Resume Next

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, i As Integer
    If Not Intersect(Target, Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row)) Is Nothing Then
        For Each c In Intersect(Target, Sheets(1).Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row))
            If IsNumeric(Cells(c.Row, 1).Value) Then
                With Sheets(2)
                    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                        If .Cells(i, 1).Value >= Sheets(1).Cells(c.Row, 1).Value Then Exit For
                    Next i
                    .Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("A" & i & ":E" & i).Value = Sheets(1).Range("A" & c.Row & ":E" & c.Row).Value
                End With
            End If
        Next c
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, i As Integer, temp As String
    If Not Intersect(Target, Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row)) Is Nothing Then
        For Each c In Intersect(Target, Sheets(1).Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row))
            If IsNumeric(Cells(c.Row, 1).Value) Then
                With Sheets(2)
                    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                        If .Cells(i, 1).Value >= Sheets(1).Cells(c.Row, 1).Value Then Exit For
                    Next i
                    .Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("A" & i & ":E" & i).Value = Sheets(1).Range("A" & c.Row & ":E" & c.Row).Value
                    temp = temp & "," & c.Row & ":" & c.Row
                End With
            End If
        Next c
        Sheets(1).Range(Mid(temp, 2, Len(temp) - 1)).Delete Shift:=xlUp
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, i As Integer, temp As String
    If Not Intersect(Target, Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row)) Is Nothing Then
        For Each c In Intersect(Target, Sheets(1).Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row))
            If IsNumeric(Cells(c.Row, 1).Value) Then
                With Sheets(2)
                    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                        If .Cells(i, 1).Value >= Sheets(1).Cells(c.Row, 1).Value Then Exit For
                    Next i
                    If .Cells(i, 1).Value = Sheets(1).Cells(c.Row, 1).Value Then _
                    .Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("A" & i & ":E" & i).Value = Sheets(1).Range("A" & c.Row & ":E" & c.Row).Value
                End With
            End If
        Next c
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, i As Integer, temp As String
    If Not Intersect(Target, Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row)) Is Nothing Then
        For Each c In Intersect(Target, Sheets(1).Range("E1:E" & Sheets(1).Cells(Sheets(1).Rows.Count, 5).End(xlUp).Row))
            If IsNumeric(Cells(c.Row, 1).Value) Then
                With Sheets(2)
                    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                        If .Cells(i, 1).Value >= Sheets(1).Cells(c.Row, 1).Value Then Exit For
                    Next i
                    If .Cells(i, 1).Value <> Sheets(1).Cells(c.Row, 1).Value Then _
                    .Rows(i & ":" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Range("A" & i & ":E" & i).Value = Sheets(1).Range("A" & c.Row & ":E" & c.Row).Value
                End With
            End If
        Next c
    End If
End Sub