Option Explicit
Sub suchen()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
fnd = InputBox("Bitte Namen eingeben")
Set myRange = Range("B:B")
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(What:=fnd, After:=LastCell)
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
Do Until FoundCell Is Nothing
Set FoundCell = myRange.FindNext(After:=FoundCell)
Cells(FoundCell.Row, 10).Interior.ColorIndex = 6
Cells(FoundCell.Row, 2).Interior.ColorIndex = 6
Set rng = Union(rng, FoundCell)
If FoundCell.Address = FirstFound Then Exit Do
Loop
rng.Select
Exit Sub
NothingFound:
MsgBox ("Nichts gefunden")
End Sub