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

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 distrib()
Dim LastRow As Long, Rw As Long 'Объявили переменный последних строк для двух листов
Dim AllRows As Object, FirstCell As Object, FoundCell As Object
' Изменить буквы текста в диапазоне на прописные.
For Each x In Range("Q3:Q1000")
    x.Value = UCase(x.Value)
Next
    Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, 3).End(xlUp).Row + 1 'Нашли номер последней строки на активном листе (там, где кнопка)
For t = 1 To 6   ' цикл общий по количеству пароходов
    m = "REGINA"
       If t = 2 Then
         m = "POLZUNOV"
       End If
       If t = 3 Then
         m = "LUKONIN"
       End If
       If t = 4 Then
         m = "SMILE"
       End If
       If t = 5 Then
         m = "FESCO"
       End If
       If t = 6 Then
         m = "UCHIURA"
       End If
   
    With Sheets(m)    'Применительно к Листам с именами пароходов
            Rw = .Cells(Rows.Count, 4).End(xlUp).Row + 1 'Нашли номер первой свободной строки на этом листе
            For i = 1 To LastRow 'Цикл со строки № 1 по последнюю заполненную (на активном листе)
                If Cells(i, 17) Like "*" & m & "*" Then 'проверили на название парохода
                Range(Cells(i, 1), Cells(i, 23)).Copy .Cells(Rw, 1) 'Дипазон (текущая строка, столбцы 1:23) копируем в первую свободную ячейку листа
                Rw = Rw + 1 'Увеличивем переменную-счётчик первой свободной строки листа
                End If
            Next
    End With
'***************** УДАЛЕНИЕ СТРОК С ПЕРВОГО ЛИСТА *******************
    Set FirstCell = Columns("Q").Find(what:="*" & m & "*", LookAt:=xlWhole)
    If FirstCell Is Nothing Then GoTo net ' если не найден пароход, то идем к следующему
        Set AllRows = Rows(FirstCell.Row)
        Set FoundCell = FirstCell
    Do
        Set FoundCell = Columns("Q").FindNext(After:=FoundCell)
        Set AllRows = Union(Rows(FoundCell.Row), AllRows)
        If FoundCell.Address = FirstCell.Address Then Exit Do
    Loop
    
    AllRows.Delete
net:
Next
End Sub

Option Explicit
Option Compare Text
 
Sub distrib()
    Dim ships$, shipsa, a(), i&, k, rw&, copyrange As Range, delra As Range
 
    Application.ScreenUpdating = False
 
    ships = "POLZUNOV|REGINA"
    shipsa = Split(ships, "|")
 
    a = Sheets("list1").[a1].CurrentRegion.Columns(17).Value
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 3 To UBound(a)
            For Each k In shipsa
                If a(i, 1) Like "*" & k & "*" Then
                    .Item(k) = .Item(k) & "," & i & ":" & i
                    Exit For
                End If
            Next
        Next
 
        For Each k In .keys
            k = UCase(k)
            If Sh_Exist(CStr(k)) Then
                With Sheets(k)
                    rw = .Cells(.Rows.Count, 4).End(xlUp).Row + 1    'Нашли номер первой свободной строки на этом листе
                End With
                Set copyrange = Range(Mid(.Item(k), 2))
                If delra Is Nothing Then Set delra = copyrange Else Set delra = Union(delra, copyrange)
                copyrange.Copy Sheets(k).Cells(rw, 1)
            End If
        Next
    End With
    If Not delra Is Nothing Then delra.EntireRow.Delete
 
    Application.ScreenUpdating = True
End Sub
 
Function Sh_Exist(sName As String) As Boolean
    Dim wsSh As Worksheet
    On Error Resume Next
    Set wsSh = Sheets(sName)
    Sh_Exist = Not wsSh Is Nothing
End Function

    a = Sheets("list1").UsedRange.Columns(17).Value