Макрос поиска и вывода строк, содержащих значение поиска

Sub SearchPN()
  Dim iCopi As Range
  Dim iPast As Range
  AR = Range("A1")   'значение для поиска
  SZ = 15
  PS = Cells(Rows.Count, 1).End(xlUp).Row
  Rows("15:" & PS).Delete Shift:=xlUp
  For I = 3 To 9
    IL = Cells(I, 5) 'номер листа
    KL = Cells(I, 6) 'номер столбца
    Cells(SZ, 2) = IL
    SZ = SZ + 1
    Set iCopi = Worksheets(IL).Range("A1:AD1")
    Set iPast = Worksheets("SEARCH").Range("A" & SZ)
    iCopi.Copy iPast
    SZ = SZ + 1
    PS = Sheets(IL).Cells(Rows.Count, KL).End(xlUp).Row
    For J = 2 To PS
      R = Val(Sheets(IL).Cells(J, KL))
      If Val(Sheets(IL).Cells(J, KL)) = AR Then
         Set iCopi = Worksheets(IL).Range("A" & J & ":AD" & J)
         Set iPast = Worksheets("SEARCH").Range("A" & SZ)
         iCopi.Copy iPast
         SZ = SZ + 1
      End If
    Next J
    SZ = SZ + 1
  Next I
End Sub
 
 
Sub Add_line()
    '
    ' Add_line Macro
    '
    ' Keyboard Shortcut: Ctrl+q
    '
    With ThisWorkbook.ActiveSheet
        Set iDiapazon = .UsedRange
        With iDiapazon
            nREnd = .Row + .Rows.Count - 1
            nCEnd = .Column + .Columns.Count - 1
        End With
        Set iDiapazon = Nothing
            
        If nREnd < 3 Then: MsgBox "Íå ïðîâåäåíî íè îäíîé îïåðàöèè.", vbInformation + vbOKOnly, "Ñîîáùåíèå ñèñòåìû": Exit Sub
            
'        MsgBox " - ñòðîêà " & nREnd & Chr(10) & " - ñòîëáåö " & nCEnd, vbInformation + vbOKOnly, "Êðàéíèå:"
        
        Rows(nREnd + 1).Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
        
        Range(.Cells(nREnd, 1), .Cells(nREnd, nCEnd)).Copy
        Range(.Cells(nREnd + 1, 1), .Cells(nREnd + 1, 1)).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
 
    End With
End Sub

AR = Range("A1")   
' и
If Val(Sheets(IL).Cells(j, KL)) = AR Then

AR = Trim(CStr(Range("A1")))
' и
If InStr(1, CStr(Sheets(IL).Cells(j, KL)), AR) > 0 Then

If CStr(Sheets(IL).Cells(j, KL)) Like AR  Then

If Looking_In Like "*" & Looking_For & "*" Then

If CStr(Sheets(IL).Cells(J, KL)) = AR Then

If CStr(Sheets(IL).Cells(J, KL)) Looking_in Like & Looking_for Like "AR" Then

If CStr(Sheets(IL).Cells(J, KL)) Like "*" & AR & "*" Then

If InStr(CStr(Sheets(IL).Cells(j, KL)), AR) <> 0 Then

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, "Ïîèñê"
End Sub

if instr(st,"бампер")<>0 and instr(st,"чери")<>0 then

if st like "*бампер*чери*" or st like "*чери*бампер*" then