Option Explicit
Sub Поиск()
Dim iShtName$, iPath$, iFileName$, firstAddress$
Dim iSheet As Worksheet, iFoundSht As Worksheet
Dim iTempWB As Workbook, iBazaWB As Workbook
Dim TextToFind As Variant, iFoundRng As Range
Dim FD As FileDialog, iLastRow&
Dim FoundAny As Boolean
    TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск")
    If TextToFind = "" Or TextToFind = False Then Exit Sub
    TextToFind = Trim(TextToFind)
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Укажите любой файл в папке"
        .ButtonName = "Выбрать папку"
        If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))
    End With
    Set FD = Nothing
    Workbooks.Add
    Sheets.Add.Name = "Поиск"
    Set iFoundSht = ActiveSheet
    iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind
    iFoundSht.Cells(1, 1).Font.Bold = True
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .StatusBar = "Идёт поиск..."
        .ShowWindowsInTaskbar = False
        iFileName = Dir(iPath & "*.xls*")
        Do While iFileName$ <> ""
            Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)
            For Each iSheet In iTempWB.Sheets
                If iSheet.FilterMode = True Then iSheet.ShowAllData
                Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                If Not iFoundRng Is Nothing Then
                    FoundAny = True
                    firstAddress = iFoundRng.Address
                    Do
                        With iFoundSht
                            iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                            If iLastRow = 1 Then iLastRow = 2
                            If iShtName <> iSheet.Name Then
                    With .Cells(iLastRow + 2, 1)
                    .Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name
                    .Font.Bold = True
                    End With
                            End If
                            iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)
                            iShtName = iSheet.Name
                        End With
                        Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)
                    Loop While iFoundRng.Address <> firstAddress
                Else
                End If
            Next
            iTempWB.Close SaveChanges:=False
            iFileName = Dir
        Loop
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    If FoundAny = False Then
        MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт"
        iFoundSht.Parent.Close SaveChanges:=False
        Exit Sub
    End If
    MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск"
'Range("A:T" & Range("A" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=SUM(R[-14]C:R[-1]C)"
'Selection.AutoFill Destination:=("A" & Rows.Count), Type:=xlFillDefault
's = Range("A:T" & Rows.Count).End(xlUp).Row
'Cells(s + 1, 1) = "=SUM(R[-14]C:R[-1]C)"
End Sub

iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind
iFoundSht.Cells(1, 1).Font.Bold = True