Wort suchen und markieren

Hallo liebe Gemeinde,
stehe vor folgendem Problem.
Ich habe ein Protokoll. In diesem möchte ich x-beliebige Wörter suchen und diese bei Treffer farblich markieren.
Ich bin mittlerweile nach reichlich Recherche so weit das ich Wörter suchen kann und finde, mir aber dann alle Wörter in dieser Zelle markiert werden - ich benötige nur das Suchwort farbig.
Mein Ansatz ist folgender


Option Explicit
Sub Suchen()
Dim strFind$, myFind, firstAdd$, i&
Dim strTemp$
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
Range(myFind.Address).Font.Color = vbRed
Set myFind = Cells.FindNext(myFind)
Loop While myFind.Address  firstAdd$
End If
Next i
End Sub

Das klappt super.
Ich scheitere im Folgenden daran, dass ich bei erneutem Aufruf des Makros keinen "Reset" hinbekomme - ergo alles auf Anfang, unabhängig ob ich dann wirklich was suche oder nicht.
Ich habe mir eine kleine Hilfsfunktion (Spalte A)gebastelt mit Abfrage ob in der vorliegenden Zeile der Suchbegriff vorkommt(schreibe "1") oder nicht (schreibe "0").
Grund dafür ist die Überlegung einer autofilter funktion im VBA code nach Erfolgter such.
Da kommt dann direkt das nächste Problem da ich in der Textbox die Suchbegriffe eingebe und meine Hilfsfunktion ja gar nicht weiss welches Wort ich suche...
Ich habe die Datei im Anhang (stark verkürzt angehangen zur Verdeutlichung.)
In B2:E2 stehen die Suchbegriffe die bei der Textboxeingabe irgendwie dahin müssen.
Ich hoffe ihr könnt mir aus der Patsche helfen.
Liebe grüße
alex
https://www.herber.de/bbs/user/118162.xlsm

Hallo alex,
ich habe Dein Makro mal etwas angepasst (rot markiert):

Sub Suchen2()
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
End Sub

Am Anfang werden alle roten Markierungen entfernt, dann werden die einzelnen Vorkommen der Suchwerte gesucht und rot markiert.
Gruß
Robert

Forumthread: Wort suchen und markieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Wörter in Excel suchen und farbig markieren

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)