Trying to find Duplicate comma delimited texts in each cell of a column

Question

I have the following macro that I got from someone, and trying to modify it to suit my purpose.

I'm trying to alter this macro to find and highlight cells that have duplicate values within each cell, for example, it should highlight B62 and B63 (green), and color font red the duplicate values (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)

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("B1", Range("B" & 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

Any help or advise is appreciated.

Answer 1

Please, try the next code, too:

Sub findComaDelDuplicates()
 Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
 Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
 
 Set sh = ActiveSheet
 With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
    arr = .value               'put the range value in an array to make the iteration faster
    .ClearFormats            'clear previous format
    .Font.Color = vbBlack 'make the font color black
 End With
 
 For i = 1 To UBound(arr)           'iterate between the array elements:
    arrInt = Split(arr(i, 1), ",")       'split the content by comma delimiter
    ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
    For Each itm In arrInt            'iterate between the comma separated elements
        arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
        If arrDif > 0 Then            'if more then an occurrence:
            If rngS Is Nothing Then             'if range to be colored (at once) does not exist:
                Set rngS = sh.Range("B" & i)  'it is crated
            Else
                Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
            End If
            mtch = Application.match(itm, arrPos, 0)       'check if the itm was already processed:
            If IsError(mtch) Then                                'if itm was not processed:
                For j = 1 To arrDif + 1                          'iterate for number of occurrences times
                    If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
                    pos = InStr(startPos, sh.Range("B" & i).value, itm)  'find first character position for the itm to be colored
                    sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
                Next j
                arrPos(k) = itm      'add the processed itm in the array
            End If
        End If
    Next
    Erase arrInt                      'clear the array for the next cell value
 Next i
 If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen        'color the interior cells of the built range
End Sub

Attention: The above code puts the range in an array to iterate much faster. But, if the range does not start form the first row, the cells to be processed must be obtained by adding to i the rows up to the first of the range. The code can be adapted to make this correlation, but I am too lazy to do it now...:)

Answer 2

The following will do that

Option Explicit

Public Sub Example()
    Dim Cell As Range
    For Each Cell In Range("A1:A10")
        HighlightRepetitions Cell, ", "
    Next Cell
End Sub

Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
    If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas

    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    Dim Data() As String
    Data = Split(Cell.Value, Delimiter)  ' split data in the cell by Delimiter 
    
    Dim StrLen As Long  ' length of the string that was already processed
    
    Dim i As Long
    For i = LBound(Data) To UBound(Data)  ' loop through all data items
        Dim DataLen As Long
        DataLen = Len(Data(i))  'get length of current item
        
        If Dict.Exists(Data(i)) Then
            ' item is a repetition: color it
            Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
            Cell.Interior.Color = vbGreen
        Else
            ' item is no repetition: add it to the dictionary
            Dict.Add Data(i), Data(i)
        End If
        
        StrLen = StrLen + DataLen + Len(Delimiter)  ' calculate the length of the processed string and add length of the delimiter
    Next i
End Sub

The following items would be colored:

You can turn ScreenUpdating off before looping in Sub Example() and turn on after the loop to stop it from flickering. Note this will not run on formuas, as parts of formula results cannot be colored. This can be prevented by using If Cell.HasFormula Or Cell.HasArray Then Exit Sub as first line.