Sub Кнопка3_Щелчок()

  Dim Sh As Worksheet, Path, tdate, ftdate, ft As String, Sh1 As Worksheet, Arr(1 To 3, 1 To 1)
    Set Sh = ActiveSheet
    Path = Sh.Range("B1")
    tdate = Sh.Range("F1")
    If tdate = "" Then ftdate = Date Else ftdate = tdate
    Set Sh = Workbooks.Add.Worksheets(1)
    Application.DisplayAlerts = False
    Sh.Parent.SaveAs Filename:=Path & "отчет " & ftdate & ".xlsx", FileFormat:= _
                     xlOpenXMLWorkbook, CreateBackup:=False
    If tdate <> "" Then ft = Left(tdate, 2) & Mid(tdate, 3, 2) & Right(tdate, 4)
    Application.DisplayAlerts = True
    Set Files = Get_files(Path)
    pz& = 1
    keys = Files.keys
    Application.ScreenUpdating = False
    For i = 0 To Files.Count - 1
        If InStr(Files.Name, ft) <> 0 Then
           Set Sh1 = Workbooks.Open(keys(i)).Worksheets(1)
           Arr(1, 1) = Files.Item(keys(i))
           Arr(2, 1) = Sh1.Cells(1, 1)
           Arr(3, 1) = Sh1.Cells(2, 1)
           Sh1.Parent.Close (False)
           Sh.Cells(pz, 1).Resize(3, 1) = Arr
           pz = pz + 4
    Next
    Sh.Parent.Save
    Application.ScreenUpdating = True
    Workbooks("отчет " & ftdate & ".xlsx").Close
 
End Sub
 
Function Get_files(ByVal Path As String)
 
    Set C_is = CreateObject("scripting.dictionary")
    Dim strFile As String
    With CreateObject("scripting.filesystemobject")
        Set curfold = .GetFolder(Path)
        If Not curfold Is Nothing Then
            For Each fil In curfold.Files
 
                If InStr(1, fil.Name, ".xls", vbTextCompare) > 0 And InStr(1, fil.Name, "_", vbTextCompare) > 0 Then
                    Z = Split(fil.Name, "_")
                    strFile = Z(UBound(Z))
                    C_is.Item(fil.Path) = strFile
                End If
            Next
 
        End If
    End With
    Set Get_files = C_is

End Function