In Excel how to replace cell interior color with two conditions

Question

In my Excel sheet, First condition is to Highlight the intersected cell with BLUE based on text matching of row and column.

Second condition: The cell values which are highlighted in Blue must Change to red if the cell value(date Format) is less than today's date.

I am able to fulfill first condition but failing to satisfy second condition.

The Excel data Looks like below:

First Condition:

Second Condition:Problem I am facing to get red interior

I am trying with a VBA Code as below:

 Sub RunCompare() Dim ws As Worksheet Set ws = ActiveSheet Dim cols As Range, rws As Range Dim lastRow As Integer: lastRow = ws.UsedRange.Rows.Count Dim lastColumn As Integer: lastColumn = ws.UsedRange.Columns.Count For Each cols In ws.Range(ws.Cells(4, 1), ws.Cells(4, lastColumn)) If cols.Value <> vbNullString Then For Each rws In ws.Range("A1:A" & lastRow) 'first condition statement If (rws.Value = cols.Value) Then ws.Cells(rws.Row, cols.Column).Interior.Color = RGB(15, 219, 241) End If 'second condition statement If (rws.Value = cols.Value) < Date Then ws.Cells(rws.Row, cols.Column).Interior.Color = RGB(255, 0, 0) End If Next End If Next End Sub

Answer 1

This can easily be done with conditional formatting.

Add two rules based on these formulas:

• RED: =AND($A3=B$1,B3<>"",B3<TODAY()) .

• BLUE: =AND($A3=B$1,B3<>"")

If you really want to keep your current VBA, you could change

If (rws.Value = cols.Value) < Date Then

to

If (rws.Value = cols.Value) And (ws.Cells(rws.Row, cols.Column).Value < Date) Then    

Or you could simplify further, by moving the RED condition inside the existing BLUE condition check ( rws.Value = cols.Value must be true for both red and blue.)

If rws.Value = cols.Value Then
    With ws.Cells(rws.Row, cols.Column) 
        If .Value < Date Then
            .Interior.Color = RGB(255, 0, 0) ' RED
        Else 
            .Interior.Color = RGB(15, 219, 241) ' BLUE
        End If
    End With
End If

Answer 2

Is this solution OK for you?

Dim ws As Worksheet

Dim col As Integer
Dim row As Integer
Dim lastRow As Integer
Dim lastCol As Integer
Dim OK As Boolean

Set ws = ActiveSheet
lastRow = ws.UsedRange.Rows.Count
lastCol = ws.UsedRange.Columns.Count

For col = 1 To lastCol
    For row = 2 To lastRow
        If ws.Cells(row, 1).Value = ws.Cells(1, col).Value Then
            If ws.Cells(row, col) < Date Then
                ws.Cells(row, col).Interior.Color = RGB(255, 0, 0)
            Else
                ws.Cells(row, col).Interior.Color = RGB(15, 219, 241)
            End If
        End If
    Next
Next