How to add cell color based of values with color gradient from red to yellow to green with a formula

Question

I have values like this:

If the values are higher than -5 or +5 they are also red. everything towards 0 gets greener like the screenshot. Formatting with the conditional format for each column is a lot of work. that is how we do it at the moment.

Is it possible to have a formula that colors the cell background like i did in the screenshot? especially with the gradient from red to yellow to green?

Here is more data.

Answer 1

A proposal for a VBA-based solution. You define two color scales: one for negative numbers and one for positive numbers. You need to select two cells (separated) to serve as the reference cells. I chose A6 and C6. You can put the whole color palette there, but it's not necessary, just one cell is enough. In these cells, the color scales will be defined first (and only once), and then the new cells will be assigned the appropriate scale depending on whether the value is negative or positive.
Once you have defined the primary scales, you need to specify the range of cells you want to format (G4:K11 in the example) and call the AppendRange procedure with this range as an argument. Only cells that contain numbers will be formatted.
If scales are assigned, you can change the values of the formatted cells, but without changing the sign. If a cell changes the sign or a new one is added, call the AppendRange procedure again. All you need to do is specify these new or changed cells as a range.

Option Explicit
Const CGreen = 8109667, CYellow = 8711167, CRed = 7039480
Public patplus As Range, patminus As Range
Sub AddRangeToCF(rng1, rng2)
    Set patplus = rng1
    DefPlus patplus.CurrentRegion
    Set patminus = rng2
    DefMinus patminus.CurrentRegion
End Sub
Sub DefPlus(rng As Range)
        rng.FormatConditions.Delete
        With rng.FormatConditions.AddColorScale(ColorScaleType:=3)
        .ColorScaleCriteria(1).Type = xlConditionValueNumber
        .ColorScaleCriteria(1).Value = 0
        .ColorScaleCriteria(1).FormatColor.Color = CGreen
        .ColorScaleCriteria(2).Type = xlConditionValuePercent
        .ColorScaleCriteria(2).Value = 50
        .ColorScaleCriteria(2).FormatColor.Color = CYellow
        .ColorScaleCriteria(3).Type = xlConditionValueNumber
        .ColorScaleCriteria(3).Value = 5
        .ColorScaleCriteria(3).FormatColor.Color = CRed
    End With
End Sub
Sub DefMinus(rng As Range)
    rng.FormatConditions.Delete
    With rng.FormatConditions.AddColorScale(ColorScaleType:=3)
        .ColorScaleCriteria(1).Type = xlConditionValueNumber
        .ColorScaleCriteria(1).Value = -5
        .ColorScaleCriteria(1).FormatColor.Color = CRed
        .ColorScaleCriteria(2).Type = xlConditionValuePercent
        .ColorScaleCriteria(2).Value = 50
        .ColorScaleCriteria(2).FormatColor.Color = CYellow
        .ColorScaleCriteria(3).Type = xlConditionValueNumber
        .ColorScaleCriteria(3).Value = 0
        .ColorScaleCriteria(3).FormatColor.Color = CGreen
    End With
End Sub
Sub AppendCell(cell As Range)
    If Application.IsNumber(cell.Value) Then
        Select Case cell.Value
            Case Is >= 0
                DefPlus Union(cell, FindSame(patplus))
            Case Is < 0
                DefMinus Union(cell, FindSame(patminus))
        End Select
    End If
End Sub

Function FindSame(pat As Range) As Range
    Set FindSame = pat.SpecialCells(xlCellTypeSameFormatConditions)
End Function

Sub AppendRange(rng As Range)
    Dim rngplus As Range, rngminus As Range, cell As Range
    Set rngplus = patplus
    Set rngminus = patminus
    For Each cell In rng
        If Application.IsNumber(cell.Value) Then
            Select Case cell.Value
                Case Is >= 0
                    Set rngplus = Union(rngplus, cell)
                Case Is < 0
                    Set rngminus = Union(rngminus, cell)
            End Select
       End If
   Next cell
   If rngplus.Count > 1 Then DefPlus Union(rngplus, FindSame(patplus))
   If rngminus.Count > 1 Then DefMinus Union(rngminus, FindSame(patminus))
End Sub

Sub Test()
    AddRangeToCF Range("C6"), Range("A6")
    AppendRange Range("G4:K11")
End Sub