Highlighting Cells based on duplicate values in Column A

[KLEINMAN]

Hi,

I would like to highlight From (A:D) if Column A shows a duplicate value. Each duplicate set needs to be in another color.

So far I can get it to highlight all duplicates but it only highlights column A.

Here is the Code:

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)

With Target
sOldAddress = .Address(external:=True)

If .Count > 1 Then

vOldValue = "Multiple Cell Select"
sOldFormula = vbNullString

Else

vOldValue = .Value
If .HasFormula Then
sOldFormula = "'" & Target.Formula
Else
sOldFormula = vbNullString
End If
End If
End With
Dim cel As Variant
Dim myrng As Range
Dim clr As Long
Set myrng = Range("A1: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("A1: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


I would really appreciate some guidance as I am a VBA beginner

 

[WarPigl3t]

     'All of your code here.
     r = 1
     lastRow = Range("A" & Rows.Count).End(xlUp).Row
     Do Until r > lastRow
          If Range("A" & r).Interior.ColorIndex <> xlNone Then
               Range("B" & r & ":D" & r).Interior.ColorIndex = clr
          End If
          r = r + 1
     Loop
End Sub

 

[sericom]

Or you could just add a resize to your 2 lines:

cel.Resize(1, 4).Interior.ColorIndex = clr

cel.Resize(1, 4).Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex

 

[KLEINMAN]

Thank you so much guys!!!

It works perfectly