Option Explicit
Public Sub SucheUndMarkiere()
Dim vntSchlagworte As Variant
If Not CBool(ErfrageSchlagworte(vntSchlagworte)) Then
Exit Sub
End If
Dim wks As Excel.Worksheet
Set wks = Worksheets("Tabelle1")
Call Reset(wks.Range("A:A,M:N"))
Dim strSchlagwort As String
Dim i As Long
For i = LBound(vntSchlagworte) To UBound(vntSchlagworte)
strSchlagwort = Trim$(vntSchlagworte(i))
Call MarkiereTextInBereich(strSchlagwort, wks.Range("M:N"), rgbRed)
Next
End Sub
Private Sub Reset(Bereich As Excel.Range)
Bereich.Font.ColorIndex = xlAutomatic
End Function
Private Function ErfrageSchlagworte(ByRef Schlagworte As Variant) As Long
Dim vntSchlagworte As Variant
vntSchlagworte = InputBox( _
Title:="Suche", _
Prompt:="Bitte geben Sie die Suchbegriffe ein." & vbNewLine _
& "Trennen Sie die Suchbegriffe mit einem Schrägstrich / ")
vntSchlagworte = Trim$(vntSchlagworte)
If Len(vntSchlagworte) = 0 Then
Schlagworte = Split(Empty)
Exit Function
End If
Schlagworte = Split(vntSchlagworte, "/")
ErfrageSchlagworte = UBound(Schlagworte) + 1
End Function
Private Sub MarkiereTextInBereich(Text As String, Bereich As Excel.Range, Color As Excel.XlRgbColor)
Dim strErsterTreffer As String
Dim rngZelle As Excel.Range
Set rngZelle = Bereich.Find(Text, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not rngZelle Is Nothing Then
strErsterTreffer = rngZelle.Address
Do
Call MarkiereTextInZelle(Text, rngZelle, Color)
Set rngZelle = Bereich.FindNext(rngZelle)
Loop While rngZelle.Address <> strErsterTreffer
End If
End Sub
Private Sub MarkiereTextInZelle(Text As String, Cell As Excel.Range, Color As Excel.XlRgbColor)
Dim rngZelle As Excel.Range
Dim i As Long, n As Long
Set rngZelle = Cell(1)
n = Len(Text)
i = InStr(rngZelle.Value, Text)
Do While i > 0
rngZelle.Characters(i, n).Font.Color = Color
i = InStr(i + n, rngZelle.Value, Text)
Loop
End Sub