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)
    WB.Activate
    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
    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

Set Rng = Sht.Cells.Find ...

If Range(g + 5, h).Value <> "Да" Or ...