Highlight duplicate cell values in a row with different color code

**picon1983** · 10-07-2017, 03:04 PM

Not even sure if it is possible:

There is a dynamic table (the range may increase or decrease by row or column.
Under each header, there are values.
Per row, if there are duplicate values, then the cells should be highlighted by different colors.

Example: Header 1 and 2 has A and A duplicate for row 2 (should be highlighted with one random color). Again, Header 4 and 5 have C as duplicate so the cells should be colored with a different color.
Image attached for suggestion.

Any color is fine as long as all the duplicates/triplicates are highlighted with similar sets of colors by row (NOT BY COLUMN).

Header1 Header2 Header3 Header4 Header5 Header6 Header7
A A B C C 1 1
V B C C 1 2 1
1 3 C D V 1 Q
123.jpg

Thanks a LOT in advance.

**PCI** · 10-07-2017, 04:29 PM

See how the macro can do the job
There is some limits: No more than 10 different duplicate
No more than 190 cells per row

Option Explicit

Sub CotlorTr()
Dim I  As Integer, J As Integer, K As Integer
Dim ColorLst
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")

    ColorLst = Array(192, 255, 49407, 65535, 5296274, 5287936, 15773696, 12611584, 6299648, 10498160)
    With ObjDic
        For I = 2 To Cells(Rows.Count, 1).End(3).Row
            .RemoveAll
            .Item(Cells(I, 1).Value) = 1
            K = 0
            For J = 2 To Cells(I, Columns.Count).End(xlToLeft).Column
                If (.exists(Cells(I, J).Value)) Then
                    If (.Item(Cells(I, J).Value) < 192) Then
                        K = K + 1
                        Cells(I, J).Interior.Color = ColorLst(K)
                        Cells(I, .Item(Cells(I, J).Value)).Interior.Color = ColorLst(K)
                    Else
                        Cells(I, J).Interior.Color = .Item(Cells(I, J).Value)
                    End If
                Else
                    .Item(Cells(I, J).Value) = J
                End If
            Next J
        Next I
    End With
End Sub

**picon1983** · 10-08-2017, 04:38 AM

Dear PCI, you are a genius.
But there is a small problem.
For example, in row 4 (in attached image), for the "C"s, the call colorsDF.JPG should be same.

**PCI** · 10-08-2017, 04:43 AM

Are the values exactly the same ...
Can you copy and paste the value from B4 to others and see the result
Can you attach a short excel sample ?

**jindon** · 10-08-2017, 04:58 AM

Try

Sub test()
    Dim i As Long, r As Range, e, n As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Cells(1).CurrentRegion
        .Interior.ColorIndex = xlNone
        For i = 2 To .Rows.Count
            For Each r In .Rows(i).Cells
                If Not dic.exists(r.Value) Then
                    Set dic(r.Value) = r
                Else
                    Set dic(r.Value) = Union(dic(r.Value), r)
                End If
            Next
            n = 2
            For Each e In dic
                If dic(e).Count > 1 Then
                    n = n + 1: If n > 49 Then n = 3
                    dic(e).Interior.ColorIndex = n
                End If
            Next
            dic.RemoveAll
        Next
    End With
End Sub

**picon1983** · 12-07-2017, 12:05 AM

Thank you jindon.

**PCI** · 10-08-2017, 05:02 AM

Yes there was a "bug" .. try next code

Option Explicit

Sub CotlorTr()
Dim i  As Integer, J As Integer, K As Integer
Dim ColorLst
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
    ObjDic.CompareMode = 1
    ColorLst = Array(192, 255, 49407, 65535, 5296274, 5287936, 15773696, 12611584, 6299648, 10498160)
    With ObjDic
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            .RemoveAll
            .Item(Cells(i, 1).Value) = 1
            K = 0
            For J = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
                If (.exists(Cells(i, J).Value)) Then
                    If (.Item(Cells(i, J).Value) < 192) Then
                        K = K + 1
                        Cells(i, J).Interior.Color = ColorLst(K)
                        Cells(i, .Item(Cells(i, J).Value)).Interior.Color = ColorLst(K)
                        .Item(Cells(i, J).Value) = ColorLst(K)          '  NEW  STATEMENT
                    Else
                        Cells(i, J).Interior.Color = .Item(Cells(i, J).Value)
                    End If
                Else
                    .Item(Cells(i, J).Value) = J
                End If
            Next J
        Next i
    End With
End Sub

**picon1983** · 12-07-2017, 12:03 AM

Thank you PCI. Big help.

Highlight duplicate cell values in a row with different color code

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Re: Highlight duplicate cell values in a row with different color code

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] highlight duplicate values in their own row even if values aren't adjacent

Highlight Duplicate Values

[SOLVED] Conditional Formatting highlight duplicate values IF cell doesn't start with "XX"

Cell color is not changing for duplicate values using VBA

Highlight duplicate values

Need help on how to highlight duplicate values

Highlight duplicate row values

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions