Hallo VBA Gemeinde,

ich komme bei einem Code nicht weiter.

Bis jetzt funktioniert es so, dass durch Eingabe in einer InputBox nach einzelnen oder mehreren Wörtern in einer Tabelle gesucht wird.

Diese einzelnen Suchwörter werden rot markiert und aus der Zelle kopiert und in die Spalte A einfügt.

Ein Reset ist auch eingebaut, sodass die rot markierten Wörter, bei erneutem Abrufen des Makros, wieder schwarz werden.

Das klappt soweit alles, aber folgende Änderungen bekomme ich, auch nach Suche im Internet, nicht wirklich umgesetzt:

-Es soll nach den Suchwörtern nicht in der ganzen Tabelle gesucht werden, sondern nur in Spalte N und M

-Dann soll das gefundene Wort/ die Wörter an der richtigen Position in Spalte A kopiert werden, bis jetzt wird es einfach ganz am Anfang von Spalte A eingefügt und nicht z.B. auf Zeile 10, wenn das gefundene Wort in Spalte N und/oder M in Zeile 10 steht

-Bei dem Reset werden nur die gefundenen Wörter wieder von rot nach schwarz gefärbt, nicht aber die Einträge in Spalte A gelöscht

Ich wäre euch dankbar, wenn ihr mir hierbei helfen könntet.

Hier ist der Code:

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