Snasui Excel Forum

Code: Select all

Sub HiliteDups()
  Dim d As Object
  Dim a As Variant, itm As Variant
  Dim i As Long, k As Long
  Dim rng As Range
  Dim bColoured As Boolean
  Set d = CreateObject("Scripting.Dictionary")
  Set rng = Range("c1", Range("c" & Rows.Count).End(xlUp))
  a = rng.Value
  For i = 1 To UBound(a)
    For Each itm In Split(a(i, 1), ",")
      d(itm) = d(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = False
  For i = 1 To UBound(a)
    k = 1
    bColoured = False
    For Each itm In Split(a(i, 1), ",")
      If d(itm) > 1 Then
        rng.Cells(i).Characters(k, Len(itm)).Font.Color = vbRed
      End If
      k = k + Len(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = True
End Sub