Assign different colors to different duplicate values in a range

Question

I'm trying to have all duplicates in a range highlighted. The twist is I want each different value to have a different color. For example all the values "Apple" would be one color. All the values "Car" would be another color etc. I've found a way to do this, although it can only be run on one Column. I need some help getting it to run on multiple columns. Here is a photo of my example:

Here is the VBA code I'm running which currently highlights only column C:

Sub different_colourTest2()
    Dim lrow As Integer
    lrow = Worksheets("Sheet2").Range("C2").CurrentRegion.Rows.Count - 1 + 2
    For N = 3 To lrow
        If Application.WorksheetFunction.CountIf(Worksheets("Sheet2").Range("C3:C" & lrow), Worksheets("Sheet2").Range("C" & N)) = 1 Then
            GoTo skip
        Else
            Worksheets("Sheet2").Range("C" & N).Interior.ColorIndex = Application.WorksheetFunction.Match(Worksheets("Sheet2").Range("C" & N), Worksheets("Sheet2").Range("C3:C" & lrow), 0) + 2
        End If
    skip:    Next N
        Worksheets("Sheet2").Activate
        Range("C3").Select
End Sub

If anyone could let me know how to have this cover a range of various columns and rows that would be greatly appreciated!

Side Note: I'm also looking for some way to not return an error when a cell in the range is empty. Not the main point of this but if someone has an answer for that would be happy to hear it as well.

Answer 1

I am sorry for not a very elegant solution. I would use a set (probably a dictionary would be even better here). A set is a data structure which takes a particular value only once. So if a certain cell contents appeared already somewhere else, a set will let me know that I am trying to add to it an element which has been already added to the set. In this way I can easily see that this element is a repetition. A wrapper in the class module is to make an easy use of an additional Ms library elements with various data structures.

I would create a class (insert class module and change its name to cls). Go to References in VBA and check Microsoft Scripting Runtime. This is importing the library to work with VBA.

In the class module paste the wrapper for Scripting.Dictionary.

Option Explicit

Private d As Scripting.Dictionary
Private Sub Class_Initialize()
    Set d = New Scripting.Dictionary
End Sub

Public Sub Add(var As Variant)
    d.Add var, 0
End Sub

Public Function Exists(var As Variant) As Boolean
    Exists = d.Exists(var)
End Function

Public Sub Remove(var As Variant)
    d.Remove var
End Sub

And in a normal VBA module paste the code which firstly adds to a set all new elements which it found in non-empty cells and later it colors them. Firstly we go through all non-empty cells and add their contents to the set allElements. At the same time all new elements we add to the set called repeated.

In the second part of the code we go once again through all non-empty cells and if their contents belongs to the set repeated, we will change their color. But we have to set the same color for all other cells with the same contents and therefore, we use a nested loop. All the cells with a particular contents get the same color. After changing their color we add their contents to yet another set - colored so we will not change their color again.

Sub different_colourTest2()

    Dim allElements As cls
    Dim repeated As cls
    Dim havecolors As cls
    Set allElements = New cls
    Set repeated = New cls
    Set havecolors = New cls
    Dim obj As Object
    Dim colorchoice As Integer
    Dim cell, cell2 As Range

   ' Go through all not empty cells and add them to allElements set
   ' If some element was found for the second time then add it to the set repeated
   For Each cell In ActiveSheet.UsedRange
        If IsEmpty(cell) = True Then GoTo Continue
        On Error Resume Next
        If (allElements.Exists(cell.Text) = True) Then repeated.Add (cell.Text)
        On Error GoTo 0
        If (allElements.Exists(cell.Text) = False) Then allElements.Add (cell.Text)

Continue:
        Next cell

'Setting colors for various repeated elements
    colorchoice = 3
    For Each cell In ActiveSheet.UsedRange
        If havecolors.Exists(cell.Text) = True Then GoTo Continue2
        If repeated.Exists(cell.Text) Then
            For Each cell2 In ActiveSheet.UsedRange()
                If cell2.Value = cell.Value Then cell2.Interior.ColorIndex = colorchoice
                On Error Resume Next
                havecolors.Add (cell.Text)
                On Error GoTo 0
            Next cell2
        End If
        If colorchoice < 56 Then colorchoice = colorchoice + 1 Else colorchoice = 2
Continue2:
    Next cell
End Sub

Answer 2

The approach I took is to sort all values in the range into a dictionary, recording the addresses of all cells relative to the cell values. So, I get a list like "B2" occurs in C20, E25, AG90. In the next step a different color is applied to each value. You can prepare as many colors as you have the patience to set up but if there aren't enough the macro will restart from the first color after it has applied the last available.

Sub MarkDuplicates()
    ' 050

    ' adjust the constants to suit
    Const FirstRow      As Long = 20
    Const FirstColumn   As String = "C"
    Const LastColumn    As String = "AG"

    Dim Dict            As Object           ' values in you declared range
    Dim Ky              As Variant          ' dictionary key
    Dim Rng             As Range            ' column range
    Dim Arr             As Variant          ' data read from the sheet
    Dim Rl              As Long             ' last used row
    Dim Cols            As Variant          ' choice of colours
    Dim Idx             As Long             ' index for colour array
    Dim Sp()            As String           ' working array
    Dim C               As Long             ' loop counter: columns
    Dim R               As Long             ' loop counter: rows


    Cols = Array(65535, 10086143, 8696052, 15123099, 9359529, 11854022)
        ' add as many colours as you wish
        '    This is how I got the color numbers:-
        '    For Each Rng In Range("E3:E8")     ' each cell is coloured differently
        '        Debug.Print Rng.Interior.Color
        '    Next Rng

    Application.ScreenUpdating = False
    Set Dict = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")               ' replace the sheet name to match your Wb
        For C = Columns(FirstColumn).Column To Columns(LastColumn).Column
            Rl = .Cells(.Rows.Count, C).End(xlUp).Row
            If Rl >= FirstRow Then
                Set Rng = .Range(.Cells(1, C), .Cells(Rl, C))
                Arr = Rng.Value
                For R = FirstRow To Rl
                    If Len(Arr(R, 1)) Then
                        ' record the address of each non-blank cell by value
                        Dict(Arr(R, 1)) = Dict(Arr(R, 1)) & "," & _
                                               Cells(R, C).Address
                    End If
                Next R
            End If
        Next C

        For Each Ky In Dict
            Sp = Split(Dict(Ky), ",")
            If UBound(Sp) > 1 Then                  ' skip unique values
                ' apply same colour to same values
                For C = 1 To UBound(Sp)
                    .Range(Sp(C)).Interior.Color = Cols(Idx)
                Next C
                Idx = Idx + 1
                ' recycle colours if insufficient
                If Idx > UBound(Cols) Then Idx = LBound(Cols)
            End If
        Next Ky
    End With
    Application.ScreenUpdating = True
End Sub

Be sure to set the name of your worksheet where it's presently shown as "Sheet1". You can also adjust the working range by modifying the values of the constants at the top of the code.