Moin mal wieder!
Fennek hat Dir doch bereits einen tollen Code gepostet.
(Daumen hoch dafür!!)
Der Rest ist doch ein Klacks.
Gruß Ralf
Hier ist der Klacks! ;)
Sub RPP()
Dim arrDouble
Dim cnt&, i&
Application.ScreenUpdating = False
With Tabelle2
arrDouble = Range(.Cells(1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With Tabelle1
For i = 1 To .Cells(1).End(xlDown).Row
For cnt = 1 To Ubound(arrDouble)
If InStr(.Cells(i, 1), arrDouble(cnt, 1)) Then
.Cells(i, 1).Characters(InStr(.Cells(i, 1), arrDouble(cnt, 1)), 5).Font.Color = vbRed
End If
Next
Next
End With
End Sub
Gruß Ralf
Hallo Ralf,
intellektuell reizt so etwas schon. Aber was soll man nun mit den "Text-Containern" anstellen?
Moin lupo!
Zitat:intellektuell reizt so etwas schon
Nur deshalb habe ich es gemacht, vllt. lässt der Chef ja etwas für den Verein springen. ;)
Zitat:Aber was soll man nun mit den "Text-Containern" anstellen?
Nix! :19:
Aber der Chef kann es sich _unter_ seine Schreibtischunterlage legen.
Gruß Ralf
Zusatz:
Nicht dass er sich die Liste mit einem monochromen Drucker …
:85:
@RPP
einfärben der Doppelten macht mein Code auch, wo ist der zusätzliche Nutzen?
mfg
Oops!
Sorry, nicht gesehen!
Hatte mich auf das Dictionary konzentriert.
Hallo Fennek,
Das Schreiben in die Tabelle kann wegfallen und die zweite Schleife benötigst Du nicht.
Deinen Code kann man so zusammenfassen:
Code:
Sub Fen2()
Dim rng As Range
Columns(1).Font.ColorIndex = xlAutomatic
With CreateObject("scripting.dictionary")
For i = 1 To 8
F0 = Split(Cells(i, "A"), ",")
For Each F In F0
If Not .exists(F) Then
.Add (F), 1
Else
.Item(F) = .Item(F) + 1
End If
Next F
Next i
For Each k In .keys
If .Item(k) > 1 Then
Set rng = Columns(1).Find(k, lookat:=xlPart)
If Not rng Is Nothing Then
Anf = rng.Address
Do
P = InStr(rng, Trim(k))
rng.Characters(Start:=P, Length:=5).Font.Color = vbRed
Set rng = Columns(1).FindNext(rng)
Loop Until Anf = rng.Address
End If
End If
Next k
End With
End Sub