CODEWITHSUNDEEP
vbaexcel
Cris Reis
Cris Reis

Reputation: 179

Excel 2010 VBA highlight with different colors cells with different duplicate values across several columns

How do I highlight with different colors duplicate cells in Excel 2010 across multiple columns?

I found this code but it works for one column.

    Sub Highlight_Duplicate_Entry()
        Dim cel As Variant
        Dim myrng As Range
        Dim clr As Long
    
        Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
        myrng.Interior.ColorIndex = xlNone
        clr = 3

        For Each cel In myrng
           If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
              If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                 cel.Interior.ColorIndex = clr
                 clr = clr + 1
              Else
                 cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
              End If
          End If
       Next
    End Sub

Upvotes: 3

Views: 9868

Answers (1)

Jon Crowell
Jon Crowell

Reputation: 22338

You need to change the range to cover multiple columns, which will cause your Match function to fail. Replace it with Find. The sub below will find any duplicates in the specified range and highlight them with a different color.

Replace your code with the following:

Sub Highlight_Duplicate_Entry()
    Dim ws As Worksheet
    Dim cell As Range
    Dim myrng As Range
    Dim clr As Long
    Dim lastCell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set myrng = ws.Range("A2:d" & Range("A" & ws.Rows.Count).End(xlUp).Row)
    With myrng
        Set lastCell = .Cells(.Cells.Count)
    End With
    myrng.Interior.ColorIndex = xlNone
    clr = 3

    For Each cell In myrng
        If Application.WorksheetFunction.CountIf(myrng, cell) > 1 Then
            ' addresses will match for first instance of value in range
            If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then
                ' set the color for this value (will be used throughout the range)
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                ' if not the first instance, set color to match the first instance
                cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex
            End If
        End If
    Next
End Sub

Adding a screen shot of the result based on a comment below to help clarify how this works. Each set of duplicates is highlighted in a separate color. Values that aren't duplicates are not colored: enter image description here

Upvotes: 4

Related Questions