Suchbegriffe einfärben
14.12.2017 10:50:35
alex
ich habe ein Protokoll und bin dank der Leute aus diesem Forum in der Lage in einer Textbox mehrere Begriffe zu suchen und diese in den Zeilen rot einzufärben.
Das funktioniert blendend - habe darüber hinaus einen autofilter drüber gesetzt damit die betreffenden zeilen rausgesucht werden.
Der Code ist folgender:
Sub Suchen()
Dim strFind$, myFind, firstAdd$, i&
Dim strTemp$
Dim Beginn As Integer, Anzahl As Integer, j As Integer
Range("U4000:U4003").ClearContents
Range("A1:S2").Select
Range("A2").Activate
Selection.AutoFilter
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
Range("U4000").Offset(i, 0).Value = strTemp
Next i
Range("A1:S2").Select
Range("A2").Activate
Selection.AutoFilter
ActiveSheet.Range("$A$1:$S$10000").AutoFilter Field:=1, Criteria1:="=1", _
Operator:=xlOr, Criteria2:="="
End Sub
Jetzt ist es so, dass wenn ich nach bspl. "Lüftung" suche, dann findet er dieses Wort auch wenn es kleingeschrieben ist (was erwünscht ist).
ABER: Es wird nicht rot makiert (logisch, gibt der Code ja auch nicht her bislang)
Gibt es hier eine praktikable Lösung, dass unabhängig von gross/kleinschreibung alle Wörter (korrekt geschrieben !) die gesucht werden rot gefärbt werden. - selbst wenn ich beispl. "lÜFTUNG" schreibe.
Danke im vorraus
LG Alex