|
Berücksichtigt jetzt auch Mehrfachtreffer von einem Begriff!
Sub Suchen()
Application.ScreenUpdating = False
Dim Qarr As Variant, Barr As Variant
Dim ZeileA As Long, ZeileB As Long, Pos2 As Long, Pos3 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(Wks1.Cells(Rows.Count, 1), Wks1.Cells(Rows.Count, 1)).End(xlUp).Row)
Barr = Wks2.Range("A2:A" & Wks2.Range(Wks2.Cells(Rows.Count, 1), Wks2.Cells(Rows.Count, 1)).End(xlUp).Row)
For ZeileA = 1 To UBound(Qarr)
Pos3 = Wks3.Range(Wks3.Cells(Rows.Count, 1), Wks3.Cells(Rows.Count, 1)).End(xlUp).Row + 1
For ZeileB = 1 To UBound(Barr)
For Pos2 = 1 To Len(Qarr(ZeileA, 1))
If InStr(Pos2, Qarr(ZeileA, 1), Barr(ZeileB, 1)) > 0 Then
Wks1.Cells(ZeileA + 1, 1).Characters(Start:=InStr(Pos2, Qarr(ZeileA, 1), Barr(ZeileB, 1)), Length:=Len(Barr(ZeileB, 1))).Font.ColorIndex = 4
Wks1.Cells(ZeileA + 1, 1).Copy Wks3.Cells(Pos3, 1)
Pos2 = InStr(Pos2, Qarr(ZeileA, 1), Barr(ZeileB, 1)) + Len(Barr(ZeileB, 1)) - 1
Else
Exit For
End If
Next Pos2
Next ZeileB
Next ZeileA
Application.ScreenUpdating = True
End Sub
Gruß Michael
|