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

In order to distinguish between duplicates or the group of duplicates, I want the above code to be limited to just two colours: light yellow and dark yellow.

To distinguish between the repeated data, I attempted to limit the above VBA code restriction to just two colours, but I'm not sure how to do so.

Answer 1

Try this:

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