Wie schreibe ich ein VB-Skript, um mehrere Schlüsselwörter in allen Zellen zu finden und jedes Schlüsselwort hervorzuheben?

Question

Ich habe derzeit eine Liste von Schlüsselwörtern (zB CFO, CTO, Interim Manager, etc.) und ich möchte ein Makro zu einer Schaltfläche, die alle Zellen in der Spalte E von Sheet 1, die diese Schlüsselwörter enthalten dann suchen können gib das Ergebnis zurück und markiere das Schlüsselwort in der Zelle.

• Jedes Schlüsselwort ist in einer separaten Zelle in Spalte A von Blatt 2.
• Wenn ein Schlüsselwort in der Liste enthalten ist, wird es für eine Suche, aber wenn es mehr sind, wird es für die Kombination suchen. Hier

ist der Screenshot zu veranschaulichen, was ich oben beschrieben

ich etwas über das Internet mit Vorschlag gefunden haben Autofilter zu verwenden, aber ich kann es nur eine Suche durchzuführen verwenden für ein Schlüsselwort Dies ist, was ich habe versucht:

Sub EmailFilter() 

Application.ScreenUpdating = False 

With Worksheets("Sheet1").Columns("E:E") 
     .AutoFilter Field:=1, Criteria1:= _ 
    "=*" & Worksheets("Sheet2").Range("A2:A10") & "*", Operator:=xlAnd 
    End With 

Application.ScreenUpdating = True 

End Sub 

Vielen Dank im Voraus.

Answer 1

Der folgende Code wird alle Übereinstimmungen mit der gleichen Farbe (ich habe blau gewählt). Sie können dieses Makro in ein Modul schreiben und dann eine Formularsteuerschaltfläche erstellen und das Makro der Schaltfläche zuweisen.

Sub macro() 
Dim a As Integer, x As String, mystring As String 
a = 2 
Sheets("Sheet2").Activate 
Cells(a, 1).Activate 
Do While ActiveCell.Value <> "" 
    x = ActiveCell.Value 
    p = Len(x) 
    Application.GoTo Sheet1.Range("E2") 
    Do While ActiveCell.Value <> "" 
     mystring = ActiveCell.Value 
     If InStr(mystring, x) > 0 Then 
      Position = InStr(1, mystring, x) 
      If Position > 0 Then 
       ActiveCell.Characters(Position, p).Font.Color = RGB(255, 0, 0) 
      End If 
     End If 
     ActiveCell.Offset(1, 0).Activate 
    Loop 
    a = a + 1 
    Application.GoTo Sheet2.Cells(a, 1) 
Loop 
End Sub 

Lassen Sie mich wissen, wenn Sie andere spezifische Anforderungen haben, damit der Code geändert werden kann. Ich hoffe das hilft.