findCell2RowCopy.vb

Sub findCell2RowCopy()
    Dim findString As Variant
    Dim firstAddress As String
    Dim findResultCell As Range
    Dim oldSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim destinationRowNumber As Long
    
    Set oldSheet = activeSheet
    destinationRowNumber = 1
    findString = Application.InputBox("input find string", Type:=2)

    If VarType(findString) = vbBoolean Or findString = "" Then
        Exit Sub
    End If

    Set findResultCell = Cells.Find(findString, , xlValues, xlWhole)
    If Not findResultCell Is Nothing Then
        firstAddress = findResultCell.Address
        Set destinationSheet = Worksheets.Add()
        oldSheet.Activate
        Do
            Rows(findResultCell.Row).Copy destinationSheet.Rows(destinationRowNumber)
            Set findResultCell = Cells.FindNext(findResultCell)
            destinationRowNumber = destinationRowNumber + 1
        Loop Until findResultCell Is Nothing Or firstAddress = findResultCell.Address
    End If
End Sub