|
Hallo Lisa
Oder auch so?
Einfärbung der Suchbegriffe
Gruß Michael
Sub Suchen()
Application.ScreenUpdating = False
Dim Qarr As Variant, Barr As Variant
Dim ZeileA As Long, ZeileB As Long
Worksheets("Tabelle1").Range("A2:A" & ActiveSheet.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row).Interior.ColorIndex = xlNone
Qarr = Worksheets("Tabelle1").Range("A2:A" & Worksheets("Tabelle1").Range(Worksheets("Tabelle1").Cells(Rows.Count, 1), Worksheets("Tabelle1").Cells(Rows.Count, 1)).End(xlUp).Row)
Barr = Worksheets("Tabelle2").Range("A2:A" & Worksheets("Tabelle2").Range(Worksheets("Tabelle2").Cells(Rows.Count, 1), Worksheets("Tabelle2").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
Worksheets("Tabelle1").Cells(ZeileA + 1, 1).Characters(Start:=InStr(1, Qarr(ZeileA, 1), Barr(ZeileB, 1)), Length:=Len(Barr(ZeileB, 1))).Font.ColorIndex = 4
Worksheets("Tabelle1").Cells(ZeileA + 1, 1).Copy Worksheets("Tabelle3").Cells(Worksheets("Tabelle3").Range(Worksheets("Tabelle3").Cells(Rows.Count, 1), Worksheets("Tabelle3").Cells(Rows.Count, 1)).End(xlUp).Row + 1, 1)
End If
Next ZeileB
Next ZeileA
Application.ScreenUpdating = True
End Sub
|