Highlight duplicates with only 2 colors

Question

Each set of duplicates either shows with light yellow or dark

Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg, xRgRow As Range
Dim xTxt, xStr As String
Dim xCell, xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
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 I = 1 To xRg.Rows.Count
On Error Resume Next
Set xRgRow = xRg.Rows(I)
For Each xCell In xRgRow.Columns
xStr = xStr & xCell.Text
Next
xCol.Add xRgRow, xStr
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xStr)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xRgRow.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
xStr = ""
Next
End Sub

I want the above code limit to two colors only, light yellow and dark yellow in order to tell apart duplicates or the set of duplicates.

I tried limiting the above VBA code limit to only two colors to tell apart the duplicated values but I'm confused how to limit it to only two colors.

Answer 1

Screesnhot/here etc. refer:

Code:

(fyi - minor amendments required for your code - essentially just manipulated the line that was changing colour each time a new pair of dups were identified - i.e. xCIndex = 2

Sub ColorCompanyDuplicates2()
'best practice to define all variables / but cbb tbh 
k = 0
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
End If
xCIndex = 27
Set xCol = New Collection
For I = 1 To xRg.Rows.Count
    On Error Resume Next
    Set xRgRow = xRg.Rows(I)
    For Each xCell In xRgRow.Columns
    xStr = xStr & xCell.Text
    Next
    xCol.Add xRgRow, xStr
    If Err.Number = 457 Then
        If Range("b2").Value = "Y" Then
            If xCIndex = 19 Then
                xCIndex = 27
            Else: xCIndex = 19
            End If
        Else
            k = k + 1
            If k = 1 Then
                go_back1 = xCellPre
            ElseIf k = 2 Then
                go_back2 = xCellPre
            Else
                xCIndex = 27
                go_back1.Interior.ColorIndex = xCIndex
                go_back2.Interior.ColorIndex = xCIndex
            End If
        End If
'xCIndex = xCIndex + 1
    
    Set xCellPre = xCol(xStr)
    If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
    xRgRow.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
    xStr = ""
    Next
End Sub

---

Deploy

Was not quite sure as to how exactly the 'dark' and 'light' shading was intended to operate (per my comment beneath your Q) - cell B2 has a drop-down validaiton list:

• "Y": i.e. alternate between light/dark shades

• "N": only have light shaded yellow if there are no more than one pair of duplicate values, thereafter change all (including those otherwise shaded light) to dark yellow*

(amend code as req. if you intended/meant something completely different; note: when changing list opion in cell B2, and re-running code - you may need to first [manually] clear/remove the fomatting from the preceeeding run - such could easily be incorporated into logic/code as req.)

---

• Have not tested columns/matrices - but code appears to be able to handle this as well

• some commentary pertained to something relating to kutools - am sure that if you took the time to copy/paste / provide data in first ainstance - no issues would have identified (besides what the OP requires/is asking about)

• Commentary was particularly constructive to say least - that aside

• here's what it looks like in action!:

---

But wait! there's more!

This may /not serve your cause, but I created a radar chart represting how often various values (in this case, 1,2,3 , col D 'Data' crop up....

Frequency table:

=LET(x_,UNIQUE(SORT(D5:D51)),HSTACK(x_,COUNTIFS(D5:D51,x_)))

requires Office 365 compatibile version of Excel.

AS you can see, initial numbers (1,2,3) start increasing in freq - there is a step up at some point RE: DB- with numer (so th arange line becomese mnore volatile - but arger.

---