Automatically highlight Duplicate Values with Various colors

Question

I have these spreadsheet file for late payers (which is normally 20+ every month). What I want to do is be able to automatically format duplicate values in different colors. Here is the VBA code I use (From other site):

Sub ColorCompanyDuplicates()
    'Updateby Extendoffice 20160704

    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long

    On Error Resume Next

    If ActiveWindow.RangeSelection.Count > 1 Then
        xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
        xTxt = ActiveSheet.UsedRange.AddressLocal
    End If

    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection

    For Each xCell In xRg     
        On Error Resume Next

        xCol.Add xCell, xCell.Text
        If Err.Number = 457 Then
            xCIndex = xCIndex + 1
            Set xCellPre = xCol(xCell.Text)
            If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
            xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
        ElseIf Err.Number = 9 Then
            MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
            Exit Sub
        End If

        On Error GoTo 0
    Next  
End Sub

This is a sample File: Click here

What I'm having problem is:

My range is A2:L50 but it colors the blank cells with Red (Although I already fixed it with Conditional Formatting values that are blank)
It doesn't automatically runs the VBA or make format duplicate cells when I make a change, I have to manually run the module after each change.
I can't assign colors to each people as we have 100+ people renting for us

Anyway, I hope someone can help me figure this out. Thanks in advance!

Pᴇʜ · Accepted Answer

To answer your 3 questions

To not color empty cells just test for empty cells with If xCell.Value <> vbNullString Then (see code below)
Another issue is that there are only 56 different colors in the color index. You start with color index = 2 (to spare out black and white) so you actually have 54 colors left. If there are more duplicates than 54 they can not be colored differently and you need to start re-using colors you already used before.
```
If xCIndex > 56 Then xCIndex = 2  '(see code below)
```
So coloring will not be unique anymore.

But you should think about that generally. Because using more then 10 or 15 colors doesn't make your worksheet clearer. If there are more then 10 colors I don't see any benefit in the different coloring at all.
Running that code automatically on any cell change can make your workbook responding unbelievable slow (if there are more than a few data rows in it). So I suggest to only run it manually (using a button or shortcut).
But you can try running it in in a Worksheet_Change event. But I think that would be just too slow.
```
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    ColorCompanyDuplicates
End Sub
```
If you run it automatically you probably want to remove the dialog box and remove coloring before re-coloring:
```
Set xRg = Range(xTxt) 'replace the original "Set xRg" line
If xRg Is Nothing Then Exit Sub
xRg.Interior.ColorIndex = xlNone 'remove old coloring
```

This is the changed code part from 1 and 2:

    If xCell.Value <> vbNullString Then 'skip coloring empty cells

        xCol.Add xCell, xCell.Text
        If Err.Number = 457 Then
            xCIndex = xCIndex + 1
            If xCIndex > 56 Then xCIndex = 2 'start re-using colors
            Set xCellPre = xCol(xCell.Text)
            If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
            xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
        ElseIf Err.Number = 9 Then
            MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
            Exit Sub
        End If

    End If

Automatically highlight Duplicate Values with Various colors

Answers (2)

Related Questions