|
HalloLisa
oder etwas überschaubarerer Code für Färbung der Suchbegriffe bezogen auf einmaligkeit jedes Begriffes!
Sub Suchen()
Application.ScreenUpdating = False
Dim Qarr As Variant, Barr As Variant
Dim ZeileA As Long, ZeileB As Long
Dim Wks1 As Worksheet, Wks2 As Worksheet, Wks3 As Worksheet
Set Wks1 = Worksheets("Tabelle1")
Set Wks2 = Worksheets("Tabelle2")
Set Wks3 = Worksheets("Tabelle3")
Wks1.Range("A2:A" & Wks1.Range(Wks1.Cells(Rows.Count, 1), Wks1.Cells(Rows.Count, 1)).End(xlUp).Row).Font.ColorIndex = 0
Qarr = Wks1.Range("A2:A" & Wks1.Range(Worksheets("Tabelle1").Cells(Rows.Count, 1), Wks1.Cells(Rows.Count, 1)).End(xlUp).Row)
Barr = Wks2.Range("A2:A" & Wks2.Range(Worksheets("Tabelle2").Cells(Rows.Count, 1), Wks2.Cells(Rows.Count, 1)).End(xlUp).Row)
For ZeileA = 1 To UBound(Qarr)
For ZeileB = 1 To UBound(Barr)
If InStr(1, Qarr(ZeileA, 1), Barr(ZeileB, 1)) > 0 Then
Wks1.Cells(ZeileA + 1, 1).Characters(Start:=InStr(1, Qarr(ZeileA, 1), Barr(ZeileB, 1)), Length:=Len(Barr(ZeileB, 1))).Font.ColorIndex = 4
Wks1.Cells(ZeileA + 1, 1).Copy Wks3.Cells(Wks3.Range(Wks3.Cells(Rows.Count, 1), Wks3.Cells(Rows.Count, 1)).End(xlUp).Row + 1, 1)
End If
Next ZeileB
Next ZeileA
Application.ScreenUpdating = True
End Sub
|