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

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

Sub Ìàêðîñ1()
Dim rn As Range, ws As Worksheet
For Each rn In Selection
  For Each ws In Worksheets
    If ws.Name <> rn.Parent.Name Then
      If Not ws.Cells.Find(rn) Is Nothing Then rn.ClearContents
    End If
  Next ws
Next rn
End Sub

If Not ws.Cells.Find(rn) Is Nothing Then rn.ClearContents: EXIT FOR

Sub tt()
    Dim tm!: tm = Timer
    Dim a(), t&, c, i&
    Dim ws As Worksheet
 
    t = ActiveSheet.Index
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For Each ws In Worksheets
            If ws.Index <> t Then
                a = ws.UsedRange.Columns(2).Value
                For Each c In a: .Item(c) = 0&: Next
            End If
        Next ws
        a = Worksheets(t).UsedRange.Columns(1).Value
        ReDim b(1 To UBound(a), 1 To 1)
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then b(i, 1) = 1
        Next
 
    End With
    Worksheets(t).UsedRange.Columns(1).Offset(, 3).Value = b
 
    Debug.Print Timer - tm
End Sub

Option Explicit
 
Sub tt() 'название роли не играет. Лишь бы компилятор не ругался :)
    Dim tm!: tm = Timer    'это будем скорость мерить, на работу кода не влияет :)
'объявляем переменные
    Dim a(), t&, c, i&    'массив, пара целочисленных Long и variant для цикла for each
    Dim ws As Worksheet    'это будет рабочий лист
 
    t = ActiveSheet.Index    'запоминаем на каком листе запускали код
    With CreateObject("scripting.dictionary")    'используем словарь
        .comparemode = 1    'сравнение без учёта регистра - по факту не актуально, но там ведь есть пву-00805-16/13, кто знает... :)
        For Each ws In Worksheets    'перебор всех рабочих листов книги (не диаграмм, не макросов или диалогов!)
            If ws.Index <> t Then    'если лист не сводный
'взяли в массив второй столбец использованной области очередного листа
'тут конечно можно набрать лишнего внизу... но лениво вычислять последнюю строку :)
                a = ws.UsedRange.Columns(2).Value
                'цикл по массиву, запоминаем в словаре значения (уникальные)
                For Each c In a: .Item(c) = 0&: Next
            End If
        Next ws    'следующий рабочий лист
 
        'взяли в массив второй столбец использованной области сводного листа
        'тут конечно тоже можно набрать лишнего внизу... но лениво вычислять последнюю строку :)
        a = Sheets(t).UsedRange.Columns(1).Value
 
        'объявляем аналогичный пустой массив
        ReDim b(1 To UBound(a), 1 To 1)
 
        'перебор проверяемого массива
        For i = 1 To UBound(a)
            'если значение есть в словаре - ставим метку в массив
            If .exists(a(i, 1)) Then b(i, 1) = 1
        Next
 
    End With    'закрыли/убили словарь - больше не нужен
 
    'выгружаем результат работы (по сдвигу на 3 столбца правее)
    Sheets(t).UsedRange.Columns(1).Offset(, 3).Value = b
    'если в UsedRange будут пустые строки (под данными или между ними) - там тоже будут метки.
    'ну это можно отсечь проверкой на пустоту - в примере это лишнее
 
    Debug.Print Timer - tm    'выводим в debug window время работы - можно посмотреть, если интересно
End Sub

Sub SearchPN()
  Sheets("SEARCH").Select
  Dim iCopi As Range
  Dim iPast As Range
  Dim ar As String
  ar = CStr(Range("A1"))   'значение для поиска
  sz = 15
  PS = Cells(Rows.Count, 1).End(xlUp).Row
  Rows("15:" & PS).Delete Shift:=xlUp
  For i = 4 To 9
    iL = Cells(i, 31) 'номер листа
    KL = Cells(i, 32) 'номер столбца
    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 CStr(Sheets(iL).Cells(j, KL)) Like 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 SearchSN()
  Sheets("SEARCH").Select
  Dim iCopi As Range
  Dim iPast As Range
  Dim ar As String
  ar = CStr(Range("A1"))   'значение для поиска
  sz = 15
  PS = Cells(Rows.Count, 1).End(xlUp).Row
  Rows("15:" & PS).Delete Shift:=xlUp
  For i = 4 To 9
    iL = Cells(i, 35) 'номер листа
    KL = Cells(i, 36) 'номер столбца
    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 CStr(Sheets(iL).Cells(j, KL)) Like 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 rr()
Dim x ' As Integer
x = Val("123456789123")
End Sub

Sub rr()
Dim x  As Integer
x = Val("33000")
End Sub