VBA Highlight Duplicate comma delimited cells in a column

[decadence]

Hi, Is there a way to highlight duplicates in comma delimited cells that are in a column, I want to compare all comma delimited text values in every cell in a column and highlight the cells that contain the duplicate text, Can someone help with this please

 

[DanteAmor]

If you have the data as the following table:

<table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:76.04px;" /><col style="width:76.04px;" /><col style="width:76.04px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td > </td><td > </td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td > </td><td style="background-color:#00ff00; ">123,abc,123</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td > </td><td >abc,dfg</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td > </td><td style="background-color:#00ff00; ">ab,ab,cd</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td > </td><td >a,b,c,d</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td > </td><td style="background-color:#00ff00; ">a,b,a,b</td><td > </td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td > </td><td > </td><td > </td></tr></table>
Use the following macro:
Change "B" for the column where your data is

Sub Highlight_Duplicate()
  Dim c As Range, v As Variant, dict As Object, w As String
  For Each c In Range("[COLOR=#0000ff]B[/COLOR]2", Range("[COLOR=#0000ff]B[/COLOR]" & Rows.Count).End(xlUp))
    Set dict = CreateObject("scripting.dictionary")
    c.Interior.Color = xlNone
    For Each v In Split(c, ",")
      w = Trim(v)
      If Not dict.exists(w) Then
        dict(w) = Empty
      Else
        c.Interior.Color = vbGreen
        Exit For
      End If
    Next
  Next
End Sub

 

[decadence]

Hi, The code works great for duplicate text within a cell, however I want to be able to find duplicate comma delimited text in all cells, is this possible?

 

[Peter_SSs]

The requirement is not clear to me. Some sample data that shows the variety of what you might have and the expected results would help.

As a start, which of these should he highlighted as duplicates. I think all of them are capable of being interpreted to meet your stated requirements but we don't really know what you mean.

A1 & A4 are exact dulplicats
A1, A2 and A4 all contain exactly the same delimited parts (though not all in the same order)
All 4 cells contain the duplicate part "abc"

Excel 2016
	A
1	abc,123,def
2	123,def,abc
3	xyz, abc
4	abc,123,def
Sheet1

 

[decadence]

Hi Peter, What I am looking to do is Find All duplicates in all cells of a column, so essentially like your previous post says 'All 4 cells contain the duplicate part "abc"', I would want to find all "abc" text and highlight those cells green and the text ("abc") a different color, lets say purple and "123" and "def" would also be found as duplicates so highlight those words purple too.

The End result would be all 4 cells are highlighted green and all comma delimited text will be purple except "xyz" as it is not duplicate text from those 4 cells

 

[Peter_SSs]

The End result would be all 4 cells are highlighted green and all comma delimited text will be purple except "xyz" as it is not duplicate text from those 4 cells

Try this in a copy of your workbook.

Sub Dupes()
  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("A1", Range("A" & 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
        If Not bColoured Then
          rng.Cells(i).Interior.Color = vbGreen
          bColoured = True
        End If
        rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
      End If
      k = k + Len(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = True
End Sub

 

[decadence]

Hi Peter, This works perfectly, Thank you

 

[Peter_SSs]

Hi Peter, This works perfectly, Thank you

You're welcome. Thanks for the follow-up.

 

[DanteAmor]

Sorry for the delay, but I also wanted to deliver my version, perhaps with another approach than Peter's macro.

Sub Highlight_Duplicate()
  Dim b() As Variant, v As Variant, m As Variant
  Dim r As Range, c As Range
  Dim n As Long, i As Long, j As Long, q As Long
  Application.ScreenUpdating = False
  Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
  r.Interior.Color = xlNone
  r.Font.ColorIndex = xlAutomatic
  n = 1
  m = Evaluate("=SUMPRODUCT(LEN(" & r.Address & ")-LEN(SUBSTITUTE(" & r.Address & ","","","""")))")
  ReDim b(1 To (m + r.Rows.Count), 1 To 3)
  For Each c In r
    q = 1
    For Each v In Split(c, ",")
      b(n, 1) = Trim(v)
      b(n, 2) = c.Row
      b(n, 3) = q
      q = q + Len(v) + 1
      n = n + 1
    Next
  Next
  For i = 1 To UBound(b)
    For j = 1 To UBound(b)
      If b(i, 1) = b(j, 1) And b(i, 2) <> b(j, 2) Then
        r.Cells(b(i, 2)).Interior.Color = vbGreen
        r.Cells(b(i, 2)).Characters(InStr(b(i, 3), r.Cells(b(i, 2)), b(i, 1)), Len(b(i, 1))).Font.Color = 12406516
        Exit For
      End If
    Next
  Next
End Sub

 

[m2pk]

Try this in a copy of your workbook.

Sub Dupes()
  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("A1", Range("A" & 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
        If Not bColoured Then
          rng.Cells(i).Interior.Color = vbGreen
          bColoured = True
        End If
        rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
      End If
      k = k + Len(itm) + 1
    Next itm
  Next i
  Application.ScreenUpdating = True
End Sub

I have a VERY goal to the original post, I have tried this macro but it didn't seem to work correctly

I've changed this line of the macro to work on Column B instead of A:

Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))

Ideally it would be great if the macro would highlight B62 and B63 (green),
and color red the duplicate value (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)