How to find and color duplicate values with Excel and VBA

by admin Leave a reply »

The obvious answer to the above question could be “by using conditional formatting, fool!” That’s true.  We could easily write a formula checking if the value just entered is a duplicate and, if it’s true, change accordingly the cell background color. We could ….. but

… what I really want is to use the same color for each duplicated value. And at the same time, use a different color for different values. It might sound complicated, but is not and the animation below should settle all the doubts.

How to find and color duplicate values with Excel and VBA

I also like the idea of having an option of easily changing the colors. To be honest, I don’t have a clue about how I could accomplish it with conditional formatting only.  And since I don’t have a clue I decided to use VBA.

In the first step I prepared a list of colors I want to use. It’s nothing, but a range with colored cells (we simply use Excel formatting).

How to find and color duplicate values with Excel and VBA

We can easily choose and change colors for duplicate values

Every time our macro finds a duplicate value in a chosen column, it will get the color from one of previously colored cells (our color list mentioned above).  Starting from the top one and moving down. When it reaches the end it will – surprise, surprise :) – start from the beginning.

Because I want my macro to run and refresh cell colors every time I change a value in a selected row I assigned the macro to Excel onChange event. And finally, my macro:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngKolory As Range

Dim rngDoPokolorowania As Range

Dim LicznikKolorow As Integer

Dim Licznik As Integer

Dim rngKolumna As Range

Dim rngDaneWypelnione As Range

' cells with colors to choose from

Set rngKolory = wksKolory.Range("rngKoloryStart").Resize(wksKolory.Range("settIleKolorow").Value, 1)

' cells with data to be "colored"

Set rngDoPokolorowania = wksDane.Range(Range("rngDaneStart"), Cells(65535, Range("rngDaneStart").Column).End(xlUp))

' column with data

Set rngKolumna = Columns("B")

With wksDane

Set rngDaneWypelnione = .Range(.Range("rngDaneStart"), .Range("rngDaneStart").Offset(10000).End(xlUp))

End With

If Not Intersect(Target, rngKolumna) Is Nothing Then

Application.ScreenUpdating = False '

' Let's clear the whole data area (set background color to default)

rngDaneWypelnione.Resize(rngDaneWypelnione.Count + 1).Interior.ColorIndex = _

wksKolory.Range("rngDomyslneTlo").Interior.ColorIndex

LicznikKolorow = 1 ' color counter reset

With rngDoPokolorowania

' first cell

If Application.WorksheetFunction.CountIf(rngDoPokolorowania, .Cells(1).Value) > 1 Then

.Cells(1).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex

LicznikKolorow = LicznikKolorow + 1

If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1

End If

'more than one cell

If rngDaneWypelnione.Count > 1 Then

' for following cells

For Licznik = 2 To .Count

If Application.WorksheetFunction.CountIf(rngDoPokolorowania, _

.Cells(Licznik).Value) > 1 Then

If Application.WorksheetFunction.CountIf(Range("rngDaneStart").Resize(Licznik - 1), .Cells(Licznik).Value) > 0 Then

.Cells(Licznik).Interior.ColorIndex = _

rngDaneWypelnione.Find(what:=.Cells(Licznik).Value, after:=.Cells(Licznik), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex

Else

.Cells(Licznik).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex

LicznikKolorow = LicznikKolorow + 1

If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1

End If

End If

Next Licznik

End If

End With

Application.ScreenUpdating = True

End If

End Sub

This might not be the most optimal solution, but in simple cases will play it’s role just fine.

Marcin

Advertisement

Comments are closed.