VBA How to add conditional formatting with graded color scale?

[Herminne]

Hello Excel experts,

I'm struggling with adding something like conditional formatting in VBA: the lower is the number, the greener must be the cell (like built-in Excel conditional formatting).

So far I was able to find and modify the following VBA code, but it crashes on the following line, plus the scale is 2-color, not 3 color, like originally in Excel.

cell.Interior.Color = RGB(255, 255 - colorValue, 255 - colorValue)

Do you know how can I do it?

Thank you very much for any suggestions in advance!

Sub UpdateConditionalFormatting(rng As Range)
    Dim cell As Range
    Dim colorValue As Integer
    Dim min As Integer
    Dim avrg As Integer
    Dim max As Integer

    min = WorksheetFunction.min(rng)
    max = WorksheetFunction.max(rng)
    avrg = WorksheetFunction.Average(rng)

    For Each cell In rng.Cells
        If (cell.Value <= avrg) Then
            colorValue = (cell.Value / max) * 255
            cell.Interior.Color = RGB(255 - colorValue, 255, 255 - colorValue)
        Else
            colorValue = (cell.Value / min) * 255
            cell.Interior.Color = RGB(255, 255 - colorValue, 255 - colorValue)
        End If

        Next cell
    End
End Sub

 

[rlv01]

To avoid crashing, make sure you are providing legal values to the RGB function. One way:

    For Each cell In rng.Cells
        If (cell.Value <= avrg) Then
            colorValue = Application.WorksheetFunction.Median(0, (cell.Value / max) * 255, 255)
            cell.Interior.Color = RGB(255 - colorValue, 255, 255 - colorValue)
        Else
            colorValue = Application.WorksheetFunction.Median(0, (cell.Value / min) * 255, 255)
            cell.Interior.Color = RGB(255, 255 - colorValue, 255 - colorValue)
        End If
    Next cell

 

[Fluff]

How about

Sub Herminne()
   Dim Cl As Range, Rng As Range
   Dim Mn As Long, Mx As Long, Av As Long
   Dim RedL As Double, GreenL As Double, BlueL As Double
   Dim RedH As Double, GreenH As Double, BlueH As Double
   Dim LowClr As String, MidClr As String, HighClr As String

   LowClr = "99,190,123"
   MidClr = "255,235,132"
   HighClr = "248,107,107"

   Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))

   Mn = Application.min(Rng)
   Mx = Application.max(Rng)
   Av = Application.Percentile(Rng, 0.5)

   RedL = GetColourFactor(MidClr, LowClr, 0, Av, Mn)
   RedH = GetColourFactor(MidClr, HighClr, 0, Av, Mx)
   GreenL = GetColourFactor(MidClr, LowClr, 1, Av, Mn)
   GreenH = GetColourFactor(MidClr, HighClr, 1, Av, Mx)
   BlueL = GetColourFactor(MidClr, LowClr, 2, Av, Mn)
   BlueH = GetColourFactor(MidClr, HighClr, 2, Av, Mx)

   For Each Cl In Rng
      If Cl <= Av Then
         Cl.Offset(, 1).Interior.Color = RGB((Cl - Mn) * RedL + Split(LowClr, ",")(0), (Cl - Mn) * GreenL + Split(LowClr, ",")(1), (Cl - Mn) * BlueL + Split(LowClr, ",")(2))
      Else
         Cl.Offset(, 1).Interior.Color = RGB((Cl - Mx) * RedH + Split(HighClr, ",")(0), (Cl - Mx) * GreenH + Split(HighClr, ",")(1), (Cl - Mx) * BlueH + Split(HighClr, ",")(2))
      End If
   Next Cl
End Sub
Function GetColourFactor(Clr1 As String, Clr2 As String, Itm As Long, Av As Long, MinMax As Long) As Double
      GetColourFactor = (Split(Clr1, ",")(Itm) - Split(Clr2, ",")(Itm)) / (Av - MinMax)
End Function

+Fluff New.xlsm
	A	B
1	CF	Macro
2	36
3	39
4	24
5	11
6	39
7	46
8	32
9	30
10	35
11	32
12	45
13	27
14	41
15	12
16	46
17	35
18	28
19	24
20	35
21	30
22	41
23	45
24	26
25	32
26	18
List

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A2:A26	Other Type	Color scale		NO

 

[Fluff]

Slightly simplified version.

Sub Herminne()
   Dim Cl As Range, Rng As Range
   Dim Mn As Long, Mx As Long, Av As Long
   Dim RedL As Double, GreenL As Double, BlueL As Double
   Dim RedH As Double, GreenH As Double, BlueH As Double
   Dim LowClr As Variant, MidClr As Variant, HighClr As Variant
   
   LowClr = Array(99, 190, 123)
   MidClr = Array(255, 235, 132)
   HighClr = Array(248, 107, 107)
   
   Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
   
   Mn = Application.min(Rng)
   Mx = Application.max(Rng)
   Av = Application.Percentile(Rng, 0.5)
   
   RedL = (MidClr(0) - LowClr(0)) / (Av - Mn)
   RedH = (MidClr(0) - HighClr(0)) / (Av - Mx)
   GreenL = (MidClr(1) - LowClr(1)) / (Av - Mn)
   GreenH = (MidClr(1) - HighClr(1)) / (Av - Mx)
   BlueL = (MidClr(2) - LowClr(2)) / (Av - Mn)
   BlueH = (MidClr(2) - HighClr(2)) / (Av - Mx)

   For Each Cl In Rng
      If Cl <= Av Then
         Cl.Offset(, 1).Interior.Color = RGB((Cl - Mn) * RedL + LowClr(0), (Cl - Mn) * GreenL + LowClr(1), (Cl - Mn) * BlueL + LowClr(2))
      Else
         Cl.Offset(, 1).Interior.Color = RGB((Cl - Mx) * RedH + HighClr(0), (Cl - Mx) * GreenH + HighClr(1), (Cl - Mx) * BlueH + HighClr(2))
      End If
   Next Cl
End Sub

 

[Fluff]

Slightly neater

Sub Herminne()
   Dim Cl As Range, Rng As Range
   Dim Mn As Long, Mx As Long, Av As Long
   Dim LowClr As Variant, MidClr As Variant, HighClr As Variant
   
   LowClr = Array(99, 190, 123)
   MidClr = Array(255, 235, 132)
   HighClr = Array(248, 107, 107)
   
   Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
   
   Mn = Application.min(Rng)
   Mx = Application.max(Rng)
   Av = Application.Percentile(Rng, 0.5)
   
   For Each Cl In Rng
      If Cl <= Av Then
         Cl.Offset(, 1).Interior.Color = GetColour(LowClr, MidClr, (Cl - Mn), (Av - Mn))
      Else
         Cl.Offset(, 1).Interior.Color = GetColour(HighClr, MidClr, (Cl - Mx), (Av - Mx))
      End If
   Next Cl
End Sub
Function GetColour(BaseClr As Variant, MidClr As Variant, Dif As Long, Avg As Long) As Long
   Dim i As Long
   Dim Clr As Double
   
   For i = 0 To 2
      Clr = (MidClr(i) - BaseClr(i)) / Avg
      GetColour = GetColour + Int((Dif * Clr + BaseClr(i))) * 256 ^ i
   Next i
End Function