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