Doppelte PLZ in verschiedenen Zellen suchen und anzeigen lassen

[RPP63]

Moin mal wieder!
Fennek hat Dir doch bereits einen tollen Code gepostet.
(Daumen hoch dafür!!)
Der Rest ist doch ein Klacks.

Gruß Ralf

[RPP63]

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

[lupo1]

Hallo Ralf,

intellektuell reizt so etwas schon. Aber was soll man nun mit den "Text-Containern" anstellen?

[RPP63]

Moin lupo!

intellektuell reizt so etwas schon

Nur deshalb habe ich es gemacht, vllt. lässt der Chef ja etwas für den Verein springen. ;)

Aber was soll man nun mit den "Text-Containern" anstellen?

Nix!  :19:
Aber der Chef kann es sich _unter_ seine Schreibtischunterlage legen.

Gruß Ralf

[RPP63]

Zusatz:
Nicht dass er sich die Liste mit einem monochromen Drucker …
:85:

[Fennek]

@RPP

einfärben der Doppelten macht mein Code auch, wo ist der zusätzliche Nutzen?

mfg

[RPP63]

Oops!
Sorry, nicht gesehen!
Hatte mich auf das Dictionary konzentriert.

[atilla]

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