Excel highlight cells with the same value in colors with VBA

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

Can we assume that the numbers are sorted like from lowest to highest as shown in the image? — Pᴇʜ, Jul 05 '21 at 12:03
You can use `Cell.Interior.Color` or other options as per [This question](https://stackoverflow.com/questions/520570/return-background-color-of-selected-cell) to read the color. And then handle them accordingly. — Christofer Weber, Jul 05 '21 at 12:05
What exactly is it that you need? What do you mean by "I need to be able to read tha value i the colored cells"? Do you just want to change your code to only do two alternating colors like in the picture, instead of a bunch of different colors? — Christofer Weber, Jul 05 '21 at 12:12

score 0 · Accepted Answer · answered Jul 05 '21 at 12:28

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.

score 0 · Answer 2 · answered Jul 05 '21 at 12:45

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

Thank you for the help, this was exactly what i wanted – TeckDragon0 Jul 05 '21 at 14:25 — TeckDragon0, Jul 05 '21 at 14:25

Excel highlight cells with the same value in colors with VBA

2 Answers2