Hi zusammen,
hier noch zwei Varianten, bei denen es darauf ankommt, wie oft ein Text auftritt:
Sub TeilDupMarkM2()
Dim oDic As Object, lngQ As Long, arQ, arT, ii As Long, strT
Dim zz As Long, ss As Long, arA() As Long, arF(1 To 7) As Long
Set oDic = CreateObject("Scripting.Dictionary")
arF(1) = RGB(255, 0, 0)
arF(2) = RGB(0, 150, 0)
arF(3) = RGB(0, 0, 255)
arF(4) = RGB(120, 120, 0)
arF(5) = RGB(120, 0, 120)
arF(6) = RGB(0, 120, 120)
arF(7) = RGB(120, 120, 120)
With Sheets(1) ' Quelldaten
lngQ = .Cells(.Rows.Count, 2).End(xlUp).Row ' Anzahl Sp. 2 = B
arQ = .Cells(1, 2).Resize(lngQ)
For zz = 1 To lngQ
arT = Split(arQ(zz, 1), ", ")
ss = 1 ' Startpos. des Teiltextes
For ii = 0 To UBound(arT)
strT = arT(ii)
If oDic.Exists(strT) Then ' wenn schon da, einfärben
arA = oDic(strT) ' alter Eintrag
arA(3) = arA(3) + 1 ' Farbnr. + 1
oDic(strT) = arA ' alten Eintrag ändern
.Cells(arA(0), 2).Characters(Start:=arA(1), _
Length:=arA(2)).Font.Color = arF(1)
' neue Fundstelle
.Cells(zz, 2).Characters(Start:=ss, _
Length:=Len(strT)).Font.Color = arF(arA(3))
Else ' neuen Eintrag anlegen
ReDim arA(3)
arA(0) = zz ' Zeile
arA(1) = ss ' ab Pos.
arA(2) = Len(strT) ' Länge
arA(3) = 1 ' Farbnr.
oDic.Add strT, arA
End If
ss = ss + Len(strT) + 2 ' Startpos. des nächsten Teiltextes
Next ii
Next zz
End With
End Sub
Sub TeilDupMarkM1()
Dim oDic As Object, lngQ As Long, arQ, arT, ii As Long, strT
Dim zz As Long, ss As Long, arA() As Long
Dim arF(1 To 6) As Long, nn As Long
Set oDic = CreateObject("Scripting.Dictionary")
arF(1) = RGB(255, 0, 0)
arF(2) = RGB(0, 150, 0)
arF(3) = RGB(0, 0, 255)
arF(4) = RGB(120, 120, 0)
arF(5) = RGB(120, 0, 120)
arF(6) = RGB(0, 120, 120)
With Sheets(1) ' Quelldaten
lngQ = .Cells(.Rows.Count, 2).End(xlUp).Row ' Anzahl Sp. 2 = B
arQ = .Cells(1, 2).Resize(lngQ)
For zz = 1 To lngQ
arT = Split(arQ(zz, 1), ", ")
ss = 1 ' Startpos. des Teiltextes
For ii = 0 To UBound(arT)
strT = arT(ii)
If oDic.Exists(strT) Then ' wenn schon da, einfärben
arA = oDic(strT) ' alter Eintrag
arA(3, 0) = arA(3, 0) + 1 ' Farbnr. + 1
ReDim Preserve arA(3, UBound(arA, 2) + 1)
arA(0, UBound(arA, 2)) = zz ' Zeile
arA(1, UBound(arA, 2)) = ss ' ab Pos.
arA(2, UBound(arA, 2)) = Len(strT) + 1 ' Länge
oDic(strT) = arA ' alten Eintrag ändern
For nn = 0 To UBound(arA, 2)
.Cells(arA(0, nn), 2).Characters(Start:=arA(1, nn), _
Length:=arA(2, nn)).Font.Color = arF(arA(3, 0))
Next nn
' neue Fundstelle
.Cells(zz, 2).Characters(Start:=ss, _
Length:=Len(strT)).Font.Color = arF(arA(3, 0))
Else ' neuen Eintrag anlegen
ReDim arA(3, 0)
arA(0, 0) = zz ' Zeile
arA(1, 0) = ss ' ab Pos.
arA(2, 0) = Len(strT) ' Länge
arA(3, 0) = 0 ' Farbnr.
oDic.Add strT, arA
End If
ss = ss + Len(strT) + 2 ' Startpos. des nächsten Teiltextes
Next ii
Next zz
End With
End Sub
Die Kommata werden hier nicht mehr mit eingefärbt.
@Matthias: Freut mich! :-)
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich