Private Function GetValue(path, file, sheet, ref)
Dim arg As String
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "Файл не найден"
Exit Function
End If
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function
Sub Найти_документы()
Const AddrresCell = 4
Dim p As String 'Директория файлов
Dim f As String 'Имя файла
Dim s As String 'Имя листа
Dim a As String 'Адрес ячейки
Dim Rng As Range, Sht As Worksheet
Dim i&, g&, h&
'Вызываем диалоговое окно для определения папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Укажите папку, в которой находятся файлы"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Отменено" 'Прекращение работы
Else
PName = .SelectedItems(1) 'Получение пути
 
'Считаем количество файлов в папке для создания массива названий файлов
FName = Dir(PName & "\*.xls") 'Получаем имя первого файла
FQuant = 0 'обнуляем кол-во файлов
' Цикл подсчета кол-ва файлов
Do Until FName = "" 'Пока имя файла не станет пустым
FQuant = FQuant + 1 'Счетчик кол-ва
FName = Dir 'Получение следующего имени файла
Loop
'Заполняем массив названиями файлов
ReDim arr(1 To FQuant) As String 'Задание размерности массива на основе кол-ва файлов
FName = Dir(PName & "\*.xls") 'Получаем имя первого файла
N = 0 'обнуляем счетчик
' Цикл заполнения массива именами файлов
Do Until FName = "" 'Пока имя файла не станет пустым
N = N + 1 'Счетчик размерности массива
arr(N) = FName 'Заполнение ячейки массива
FName = Dir 'Получение следующего имени файла
Loop
N = 0
'Цикл перебора файлов
d = InputBox("Что ищем?")
If IsNull(d) Then Exit Sub
For N = 1 To FQuant
    p = PName & "\" 'Директория файлов
    f = arr(N) 'получаем имя файла
    s = Left(arr(N), Len(arr(N)) - 5) 'получаем имя листа
    On Error Resume Next
    Set WB = Application.Workbooks.Open(p & f)
    With GetObject(p & f)
    For Each Sht In WB.Sheets 'цикл по всем листам в файле
        Set Rng = Sht.Cells.Find(d, , xlFormulas, xlWhole) 'xlWhole - ячейка целиком, xlPart - часть ячейки
        If Not Rng Is Nothing Then 'если нашли
            'MsgBox "Найдено на листе " & Rng.Parent.Name & " в ячейке " & Rng.Address(0, 0), vbInformation, "Конец"
            For Each Cell In Rng
                     g = Rng.Adress.Row
                     h = Rng.Adress.Column
                     If Range(g + 5, h).Value <> "Да" Or Range(g + 5, h).Value <> "ДА" Or Range(g + 5, h).Value <> "да" Then
                        For i = 1 To Rng
                            If Range(g, h) = Range("D", h) Then
                               MsgBox (Workbooks(f).Range(g - 3, h).Value)
                               Workbooks("Поиск.xlsm").Range("B" & i).Value = Workbooks(f).Range(g - 3, h).Value
                               Workbooks("Поиск.xlsm").Range("C" & i).Value = Workbooks(f).Range(g - 1, h).Value
                               Workbooks("Поиск.xlsm").Range("D" & i).Value = Workbooks(f).Range(g + 2, h).Value
                               Workbooks("Поиск.xlsm").Range("E" & i).Value = Workbooks(f).Range(g + 3, h).Value
                            ElseIf Range(g, h) = Range("H", h) Then
                               Workbooks("Поиск.xlsm").Range("B" & i).Value = Workbooks(f).Range(g - 4, h).Value
                               Workbooks("Поиск.xlsm").Range("C" & i).Value = Workbooks(f).Range(g + 1, h).Value
                               Workbooks("Поиск.xlsm").Range("D" & i).Value = Workbooks(f).Range(g + 4, h).Value
                               Workbooks("Поиск.xlsm").Range("E" & i).Value = Workbooks(f).Range(g + 3, h).Value
                            End If
                        Next i
                    End If
            Next Cell
        End If
    Next Sht
    End With
    If Rng Is Nothing Then 'если не нашли
       GoTo Metka
    End If
Metka:
WB.Close
Next N
     If Rng Is Nothing Then 'если не нашли
        MsgBox "Не найдено ни на одном листе!", vbExclamation, "Конец"
     End If
End If
End With
End Sub

For Each Cell In Rng                     g = Rng.Adress.Row
                     h = Rng.Adress.Column
                     If Range(g + 5, h).Value <> "Да" Or Range(g + 5, h).Value <> "ДА" Or Range(g + 5, h).Value <> "да" Then
                        For i = 1 To Rng
                            If Range(g, h) = Range("D", h) Then
                               MsgBox (Workbooks(f).Range(g - 3, h).Value)
                               Workbooks("Поиск.xlsm").Range("B" & i).Value = Workbooks(f).Range(g - 3, h).Value
                               Workbooks("Поиск.xlsm").Range("C" & i).Value = Workbooks(f).Range(g - 1, h).Value
                               Workbooks("Поиск.xlsm").Range("D" & i).Value = Workbooks(f).Range(g + 2, h).Value
                               Workbooks("Поиск.xlsm").Range("E" & i).Value = Workbooks(f).Range(g + 3, h).Value
                            ElseIf Range(g, h) = Range("H", h) Then
                               Workbooks("Поиск.xlsm").Range("B" & i).Value = Workbooks(f).Range(g - 4, h).Value
                               Workbooks("Поиск.xlsm").Range("C" & i).Value = Workbooks(f).Range(g + 1, h).Value
                               Workbooks("Поиск.xlsm").Range("D" & i).Value = Workbooks(f).Range(g + 4, h).Value
                               Workbooks("Поиск.xlsm").Range("E" & i).Value = Workbooks(f).Range(g + 3, h).Value
                            End If
                        Next i
                    End If
            Next Cell
        End If
    Next Sht