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