Option Explicit
Sub DoAllRows()
Dim r As Long
Application.ScreenUpdating = False
With ActiveSheet
With .Range("C3:N60")
.FormatConditions.Delete
.Interior.ColorIndex = xlColorIndexNone
'clear any empty, but text i.e. 0 length strings
Call .Replace(vbNullString, "###ZZZ###", LookAt:=xlWhole)
Call .Replace("###ZZZ###", vbNullString, LookAt:=xlWhole)
'clear the settings
.Find What:=vbNullString, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False
.Replace What:=vbNullString, Replacement:=vbNullString, ReplaceFormat:=False
End With
' https://www.rondebruin.nl/win/s9/win012.htm
' Excel 97 = 8
' Excel 2000 = 9
' Excel 2002 = 10
' Excel 2003 = 11
' Excel 2007 = 12
' Excel 2010 = 14
' Excel 2013 = 15
' Excel 2016 = 16
' Excel 2019 and Excel 365 also give you number 16
If Application.Version > 12 Then
For r = 3 To 60
Call AddCF(r)
Next r
Else
For r = 3 To 60
Call AddInteriorColor(r)
Next r
End If
End With
Application.ScreenUpdating = True
End Sub
Private Sub AddInteriorColor(rowNum As Long)
Dim T1 As Long, T2 As Long, T3 As Long, T4 As Long, T0 As Long
Dim r As Range
Dim c As Long
Set r = ActiveSheet.Rows(rowNum)
With r
If .Cells(1, 15).Value = 0 Then Exit Sub ' no threshholds
T0 = .Cells(1, 1).Value
T1 = .Cells(1, 15).Value
T2 = .Cells(1, 16).Value
T3 = .Cells(1, 17).Value
T4 = .Cells(1, 18).Value
Set r = r.Cells(1, 3).Resize(1, 12)
End With
With r
For c = 1 To 12 ' r starts in col C
If .Cells(1, c).Value >= T0 + T4 Then
.Cells(1, c).Interior.Color = vbRed
ElseIf .Cells(1, c).Value >= T0 + T3 Then
.Cells(1, c).Interior.Color = vbYellow
ElseIf .Cells(1, c).Value >= T0 + T2 Then
.Cells(1, c).Interior.Color = vbGreen
ElseIf .Cells(1, c).Value >= T0 + T1 Then
.Cells(1, c).Interior.Color = vbBlue
End If
Next c
End With
End Sub
Private Sub AddCF(rowNum As Long)
Dim T1 As Long, T2 As Long, T3 As Long, T4 As Long
Dim CFormula As String
Dim r As Range
Set r = ActiveSheet.Rows(rowNum)
With r
If .Cells(1, 15).Value = 0 Then Exit Sub ' no threshholds
T1 = .Cells(1, 15).Value
T2 = .Cells(1, 16).Value
T3 = .Cells(1, 17).Value
T4 = .Cells(1, 18).Value
CFormula = "=$A" & .Cells(1, 1).Row & "+"
Set r = r.Cells(1, 3).Resize(1, 12)
End With
With r
.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual, Formula1:=CFormula & T4
.FormatConditions(.FormatConditions.Count).Interior.Color = vbRed
.FormatConditions(.FormatConditions.Count).StopIfTrue = True
.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual, Formula1:=CFormula & T3
.FormatConditions(.FormatConditions.Count).Interior.Color = vbYellow
.FormatConditions(.FormatConditions.Count).StopIfTrue = True
.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual, Formula1:=CFormula & T2
.FormatConditions(.FormatConditions.Count).Interior.Color = vbGreen
.FormatConditions(.FormatConditions.Count).StopIfTrue = True
.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual, Formula1:=CFormula & T1
.FormatConditions(.FormatConditions.Count).Interior.Color = vbBlue
.FormatConditions(.FormatConditions.Count).StopIfTrue = True
End With
End Sub