Public Sub Поиск_во_всех_файлах()
 
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
 
On Error GoTo ErrHandler
 
Application.ScreenUpdating = False
 
strPath = "C:\ПОИСК" 'поменять на ваш путь
strSearch = InputBox("Поиск в папке C ПОИСК:", "Форма поиска", "")
 
If strSearch = "" Then
  Exit Sub
End If
 
Set wOut = Worksheets.Add
lRow = 1
 
With wOut
  .Cells(lRow, 1) = "Книга"
  .Cells(lRow, 2) = "Лист"
  .Cells(lRow, 3) = "Ячейка"
  .Cells(lRow, 4) = "Результат"
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fld = fso.GetFolder(strPath)
  strFile = Dir(strPath & "\*.xls*")
  Do While strFile <> ""
    Set wbk = Workbooks.Open(Filename:=strPath & "\" & strFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
    For Each wks In wbk.Worksheets
      Set rFound = wks.UsedRange.Find(strSearch)
      If Not rFound Is Nothing Then
        strFirstAddress = rFound.Address
      End If
      Do
        If rFound Is Nothing Then
          Exit Do
        Else
          lRow = lRow + 1
          .Cells(lRow, 1) = wbk.Name
          .Cells(lRow, 2) = wks.Name
          .Cells(lRow, 3) = rFound.Address
          .Cells(lRow, 4) = rFound.Value
        End If
        Set rFound = wks.Cells.FindNext(After:=rFound)
      Loop While strFirstAddress <> rFound.Address
    Next
    'wbk.Close (False)
    strFile = Dir
  Loop
  .Columns("A:D").EntireColumn.AutoFit
End With
 
MsgBox "Все"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
 
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
 
End Sub