Sub Поиск()
Dim iFoundRng As Range
Dim iSheet As Worksheet
Dim iFoundSht As Worksheet
Dim firstAddress As String
Dim TextToFind As Variant
Dim TextToFindA As Variant
Dim i As Variant
Dim iLastRow As Long
    
    Set iFoundSht = Sheets("Поиск") 'лист "Поиск" присваиваем переменной
    iFoundSht.Range("F3:F5000").Clear 'очищаем диапазон ячеек на листе Поиск
    TextToFindA = iFoundSht.Range("A2:B38") 'здесь задайте диапазон поиска+критериев отбора "да/нет", можно через InputBox
    For i = 1 To UBound(TextToFindA, 1)
        If TextToFindA(i, 2) = "да" Then TextToFind = TextToFind & "*" & Trim(TextToFindA(i, 1))
    Next i
    If TextToFind = "" Or TextToFind = False Then Exit Sub 'если ничего не ввели - Выход!
    TextToFind = Trim(TextToFind) 'убираем начальные и конечные пробелы
    Application.ScreenUpdating = False 'отключаем обновление экрана
    For Each iSheet In ThisWorkbook.Worksheets 'поиск по листам
        If iSheet.Name <> iFoundSht.Name Then
            If iSheet.FilterMode = True Then iSheet.ShowAllData 'если на листе установлен автофильтр, то снимаем его
            Set iFoundRng = iSheet.Range("A1:A10000").Find(TextToFind, , xlFormulas, xlPart)
            If Not iFoundRng Is Nothing Then 'если нашли
                firstAddress = iFoundRng.Address 'запоминаем адрес найденной ячейки, чтобы продолжить поиск по листу
                Do
                    With iFoundSht
                        iLastRow = .Cells(.Rows.Count, 6).End(xlUp).Row 'определяем последнюю заполненную строку на листе поиск
                        If iLastRow = 2 Then iLastRow = 3 'если лист пуст, то вставлять будем начиная с 4-й строки
                            With .Cells(iLastRow + 1, 6) 'проставляем имя листа
                                .Value = iFoundRng.Text
                                'добавляем гиперссылку
                                iFoundSht.Hyperlinks.Add Anchor:=iFoundSht.Cells(iLastRow + 1, 6), Address:="", _
                                    SubAddress:="'" & iSheet.Name & "'" & "!" & iFoundRng.Address, ScreenTip:="Перейти на лист " & iSheet.Name
                                '.Font.Bold = True 'выделяем жирным
                            End With
                    End With
                    Set iFoundRng = iSheet.Range("A1:A10000").FindNext(iFoundRng) 'продолжаем поиск на том же листе
                Loop While iFoundRng.Address <> firstAddress
            End If
        End If
    Next iSheet
    Application.ScreenUpdating = True 'включаем обновление экрана
    MsgBox "Поиск завершён!", 64, "Поиск"
End Sub