Excel highlight cells with the same value in colors with VBA - excel

Question

Excel highlight cells with the same value in colors
I need a macro that will color all duplicate cells with colors,
I need to color the cells in different colors, to Cell A2 and Cell A3 can have the same value like 50, and Cell A4 and A5 can have the value of 60, And Cell A7,A8 and A9 can have tha value of 40, or Cell A11, A15 and A20 can have tha value of 250.
I need the colors to not be the same if the value is different so Cells A2 and A3 can be yellow if the value is duplicate , then Cell A4 and A5 can be Orange, Cells A7, A8 and A9 can be yellow.
The problem is that it I can have an Excel files from 10 cells to 600 cells, So It can take forever to do manually.
I have a macro that can color in this way, but I need to be able to read tha value i the colored cells, something my macro can't do.
Is it possible to do something like this in VBA?
VBA Code:
Dim ws As Worksheet
Dim clr As Long
Dim rng As Range
Dim cell As Range
Dim r As Range
Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
Set rng = ws.Range("A2:a" & Range("A" & ws.Rows.Count).End(xlUp).Row)
With rng
Set r = .Cells(.Cells.Count)
End With
rng.Interior.ColorIndex = xlNone
clr = 3
For Each cell In rng
If Application.WorksheetFunction.CountIf(rng, cell) > 1 Then
'addresses will match for first instance of value in range
If rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).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 = rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Interior.ColorIndex
End If
End If
Next
End Sub

Answer 1

If all you want to do is have an alternating color like in the picture, you only need to change the row clr = clr + 1 to something like the following.
If clr = 44 Then
clr = 45
Else
clr = 44
End If
Those are an estimation of the color in the picture. You also want to change clr = 3 to clr = 44 or whatever color you and up using.

Answer 2

If the numbers are sorted ascending or descending (like in your image) then you can do this much faster than using the find method.
Option Explicit
Public Sub ColorDuplicatesAlternate()
Dim ws As Worksheet ' define your sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' find last used row
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range ' read data range
Set DataRange = ws.Range("A1", "A" & LastRow + 1)
Dim DataValues() As Variant ' read data into array for fast processing
DataValues = DataRange.Value
Dim iStart As Long
iStart = 1
Dim BlockValue As Variant
Dim IsEven As Boolean
Dim EvenBlocks As Range
Dim OddBlocks As Range
Dim CurrentBlock As Range
Dim iRow As Long
For iRow = LBound(DataValues) + 1 To UBound(DataValues) ' loop through all data and find blocks, collect them in even and odd numbered blocks for alternate coloring
If BlockValue <> DataValues(iRow, 1) Then
If iRow - iStart > 1 Then
Set CurrentBlock = DataRange.Cells(iStart, 1).Resize(RowSize:=iRow - iStart)
If IsEven Then
If EvenBlocks Is Nothing Then
Set EvenBlocks = CurrentBlock
Else
Set EvenBlocks = Union(EvenBlocks, CurrentBlock)
End If
Else
If OddBlocks Is Nothing Then
Set OddBlocks = CurrentBlock
Else
Set OddBlocks = Union(OddBlocks, CurrentBlock)
End If
End If
IsEven = Not IsEven
End If
iStart = iRow
BlockValue = DataValues(iRow, 1)
End If
Next iRow
' color all even and odd blocks alternating
EvenBlocks.Interior.Color = vbRed
OddBlocks.Interior.Color = vbGreen
End Sub