Colour duplicate text with different colours

[Katkodes]

Hi all! I’m looking for some VBA help please! Does anyone have code that can help me find duplicate text in a column and highlight each pair as it were in a different colour?

I know the text is an exact match because I used data validation, and I can get the duplicates to flag up using my a simple conditional formatting, however I want the column itself to light up a different colour rather than use the countif function I’ve seen recommended when using conditional formatting.

Any help would be great thank you!

 

[Trebor76]

Hi Katkodes,

Welcome to MrExcel!!

The following can probably can be done more efficiently but it does the job:

Option Explicit
Sub ColourDups()

    Dim strFltrItems() As String
    Dim wsSrc As Worksheet
    Dim rngCell As Range, rngRange As Range
    Dim i As Long
    Dim clnItems As New Collection
    Dim varItem As Variant
    Dim bteRed As Byte, bteGreen As Byte, bteBlue As Byte
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") 'Sheet name containing the data. Change to suit.
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    Set rngRange = wsSrc.Range("A1", wsSrc.Range("A" & Rows.Count).End(xlUp)) 'Ensure the header does not appear in the list or else it will be coloured as well.
    rngRange.Interior.Color = xlNone
    
    For Each rngCell In rngRange
        If WorksheetFunction.CountIf(rngRange, rngCell) > 1 Then
            On Error Resume Next
                clnItems.Add CStr(rngCell.Value), rngCell.Value
            On Error GoTo 0
        End If
    Next rngCell
    
    For Each varItem In clnItems
        rngRange.AutoFilter Field:=1, Criteria1:="=" & CStr(varItem)
        bteRed = WorksheetFunction.RandBetween(0, 255)
        bteGreen = WorksheetFunction.RandBetween(0, 255)
        bteBlue = WorksheetFunction.RandBetween(0, 255)
        For Each rngCell In rngRange.Offset(1, 0).SpecialCells(xlCellTypeVisible)
            If rngCell.Value = CStr(varItem) Then 'Double ensure the value in cell to be coloured matches the current item in the clnItems collection
                rngCell.Interior.Color = RGB(bteRed, bteGreen, bteBlue)
            End If
        Next rngCell
    Next varItem
    
    On Error Resume Next
        wsSrc.ShowAllData
    On Error GoTo 0
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert