Sub проверка()



Application.ScreenUpdating = False

Workbooks("Книга1.xls").Activate

Dim i, z, poisk, y

    i = 1

    y = 0



start:



    i = i + 1

        Sheets("Лист2").Select

        z = Range("A" & i)

    If z = Empty Then

        Application.ScreenUpdating = True

        Sheets("Лист2").Select

        MsgBox "Нашли и перенесли - " & y

End

    Else

    End If

    

        Sheets("Лист1").Select

        Cells(1, 1).Select

    

povtor:



    With Sheets("Лист1").Columns(1)

        'Переменная (poisk)

    Set poisk = Cells.Find(What:=z, After:=ActiveCell, _

        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _

        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    End With

                                            

    If poisk Is Nothing Then

GoTo start

    'Else

    End If

        poisk.Select

        ActiveCell.EntireRow.Select

        Selection.Copy

    

        Sheets("Лист3").Select

        Rows("2:2").Select

        Selection.Insert Shift:=xlDown

    

        Sheets("Лист1").Select

        Selection.Delete

                              

    y = y + 1

GoTo povtor

    'GoTo start

End Sub

P.S. xlPart искать с частью ячейки, xlWhole - искать ячейку целиком

Если же у вас в одной ячейке и имя и фамилия и отчество, то попробуйте добавлять к фамилии, которую вы ищите пробел, т.е. Смирнов+пробел, тогда поиск не будет находить Смирнова, а будет находить только Смирнов.

Для этого вам надо перед строкой Sells.Find добавить строку

z = z & " "

P.S.S. Когда выкладываете код программы, пожалуйста, берите свой код в тэги

[.code]

... Ваш код...

[./code]

Только без точек, которые я указал внутри тэгов (это чтобы вы увидели эти тэги)

По-моему, будет более правильно искать слово с добавлением пробелов

1) если ищем по фамилии, то добавляем z = z & " "  (конечный пробел)

2) если ищем по имени, то добавляем z = " " & z & " "  (и начальный и конеч. пробелы)

3) если ищем по отчеству, то добавляем z = " " & z  (начальный пробел)

Я тут немного оптимизировал ваш код, посмотрите на изменения

1) Желательно всегда объявлять переменные с указанием типа, т.е. не просто Dim i  (это тоже самое, что и Dim i as Variant, т.е. зря будет выделено много памяти), а Dim i as Long  (или Dim i&  (& - это Long), т.к. вы знаете что i будет целым числом (т.е. номер ряда 1, 2, 3, 4 и т.д.). Переменная z всегда будет текстом, поэтому Dim z as String (или Dim z$), таким образом вместо

Dim i, z, poisk, y

правильнее написать

Dim i As Long, z As String, Poisk As Variant, y As Long

Sheets("Лист2").Select
z = Range("A" & i)

можно записать

z = Sheets("Лист2").Range("A" & i)

If poisk Is Nothing Then
GoTo start
Else
End If

If poisk Is Nothing Then GoTo start

 4) Копирование информации с одного листа на другой также можно оптимизировать, чтобы было без выделения каких либо листов (первого, а потом третьего и так по кругу), т.е. вместо 7-ми строчек кода

poisk.Select
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("Лист3").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Sheets("Лист1").Select

можно написать одной

Poisk.Copy Destination:=Sheets("Лист3").Cells(iRaz + 1, 1)

Таким образом мы получаем

Sub Проверка()
    Dim i As Long, z As String, Poisk As Variant, y As Long, iRaz As Long
    'Dim i&, z$, Poisk As Variant, y&, iRaz& 'тоже самое, но короче
    
    'Application.ScreenUpdating = False
    'Workbooks("Книга1.xls").Activate
    iRaz = 1
    i = 1
    y = 0
Start:
    i = i + 1
    z = Sheets("Лист2").Range("A" & i)
    If z = Empty Then
        Application.ScreenUpdating = True
        Sheets("Лист2").Select
        MsgBox "Нашли и перенесли - " & y
        End
    End If
Povtor:
    With Sheets("Лист1").Columns(1)
        'z = " " & z         'добавляем пробел перед словом
        'z = z & " "         'добавляем пробел в конце слова
        'z = " " & z & " "   'добавляем пробелы в начало и в конец слова
        Set Poisk = .Find(What:=z, LookIn:=xlValues)
    End With
    If Poisk Is Nothing Then GoTo Start
    iRaz = iRaz + 1
    Poisk.Copy Destination:=Sheets("Лист3").Cells(iRaz + 1, 1)
    Poisk.EntireRow.Delete
    y = y + 1
GoTo Povtor
    'GoTo start
End Sub

P.S. уверен, что другие участники форума ещё что-нибудь своё предложать вам.

P.S.S. При поиске значения знак вопроса "?" и будет любой один знак, звёздочка "*" - много знаков )

Я бы посоветовал вводить ФИО в отдельную ячейку и обязательно не прямым вводом в ячейку, а через список. Список, естественно, должен быть с возможностью пополнения.

Желаю успехов.