Search code examples
excelvbaif-statementoffset

How do I fill the color of the cell below the active cell if the next value is the same?

I have a set of data with one column that contains two specific values that should alternate down each row.

The data looks like this:
Data

The goal is to fill Cell C6 Red.

The number of rows in the worksheet will change weekly, but the pattern "Break, Normal, Break" should remain consistent.
When "Break, Normal, Normal" occurs, the last "Normal" needs to be filled to indicate that a break is missing.

My solution is to begin at C2, and if C3 is equal to C2, then fill C3 red. Then, step down a row and repeat the check until the end of the list. This logic would indicate that C6 turns red when C5 is Active.

Sub Compare_Rows()
   
    Range("C2").Select
     
    If (ActiveCell.Value = ActiveCell.Offset(1, 0).Value) Then
        ActiveCell.Offset(1, 0).Interior.ColorIndex = 3
    End If

    Do Until IsEmpty(ActiveCell)
        ActiveCell.Offset(1, 0).Select
    Loop
    
End Sub

In review I added a break at the If and Loop lines, and the program does select each cell one row at a time. In this example when C5 is active, the tooltip for the two values in the If line confirm that the criteria (identical values) is met, but the target cell remains without any color.

The tooltip for the ColorIndex shows a color index of "-4142" at all times.

Solution

  • Please, use the next code. It places the range in an array, for faster iteration/processing and build a Union range of duplicate cells value to be colored at the end of the code, at once:

       Dim sh As Worksheet, lastR As Long, rngCol As Range, arr, i As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
   
   arr = sh.Range("C1:C" & lastR).Value2
   
   For i = 2 To UBound(arr)
        If arr(i, 1) = arr(i - 1, 1) Then addToRange rngCol, sh.Range("C" & i)
   Next i
   If Not rngCol Is Nothing Then rngCol.Interior.Color = vbRed
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

    Your code loops for nothing until it reaches the first empty cell...