Sub Poisk()
Dim List3 As Worksheet
Dim Slovo As String
Dim MyArr
Dim i As Integer
Dim iLastRow As Integer
Dim j As Integer
Dim iLR_2 As Integer
Dim iLR_3 As Integer
Dim k As Integer
  Set List3 = ThisWorkbook.Worksheets("Лист3")
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  With Worksheets("Лист2")
    For i = 2 To iLastRow
       iLR_2 = .Cells(Rows.Count, "A").End(xlUp).Row
      If Not IsEmpty(Cells(i, "A")) Then
          Slovo = Cells(i, "A")
        For j = iLR_2 To 2 Step -1
          If InStr(1, .Cells(j, "A"), Slovo) <> 0 Then
            MyArr = Split(.Cells(j, "A"), " ")
            For k = 0 To UBound(MyArr)
              If MyArr(k) = Slovo Then
                iLR_3 = List3.Cells(List3.Rows.Count, "A").End(xlUp).Row + 1
                List3.Cells(iLR_3, "A") = .Cells(j, "A")
                .Rows(j).Delete
                Exit For
              End If
            Next
          End If
        Next
      End If
    Next
  End With
End Sub