Option Explicit
Sub Suchen()
Dim strFind$, myFind, firstAdd$, i&
Dim strTemp$
Dim Beginn As Integer, Anzahl As Integer, j As Integer
ActiveSheet.UsedRange.Font.ColorIndex = xlAutomatic
strFind$ = InputBox("Bitte geben Sie die Suchbegriffe ein." & vbNewLine _
& "Trennen Sie die Suchbegriffe mit einem Schrägstrich / ", "Suche")
If strFind$ = vbNullString Then Exit Sub
For i = LBound(Split(strFind$, "/")) To UBound(Split(strFind$, "/"))
strTemp$ = Trim(Split(strFind$, "/")(i))
Set myFind = Cells.Find(strTemp$, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not myFind Is Nothing Then
firstAdd$ = myFind.Address
Do
Anzahl = (Len(myFind) - Len(Replace(myFind, strTemp$, ""))) / Len(strTemp)
Beginn = 0
For j = 1 To Anzahl
Beginn = InStr(Beginn + 1, myFind.Value, strTemp$)
myFind.Characters(Start:=Beginn, Length:=Len(strTemp$)).Font.Color = vbRed
Next j
Set myFind = Cells.FindNext(myFind)
Loop While myFind.Address <> firstAdd$
End If
Next i
Range("A2").Value = strFind
End Sub