Excel: Dual graded color scales
All right, I got kind of sick of this question sticking out there. I wrote this macro, it sorts ascending, divides the non-blank range in half (rounded up) and applies two color scales. Modify as you wish.
Sub TestColorScale()
Application.ScreenUpdating = False
'sort ascending
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A:A")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'count cells
Dim intcount As Integer
Dim rngcount As Range
Set rngcount = Range("A:A")
intcount = Application.WorksheetFunction.CountA(rngcount)
rngcount.FormatConditions.Delete
'Get half
Dim inthalf As Integer
inthalf = intcount / 2
inthalf = Application.WorksheetFunction.RoundUp(inthalf, 0)
'Do first half
Dim rng1 As Range
Set rng1 = Range(Cells(1, 1), Cells(inthalf, 1))
' Add a 2-color scale.
Dim cs1 As ColorScale
Set cs1 = rng1.FormatConditions.AddColorScale(ColorScaleType:=2)
' Format the first color
With cs1.ColorScaleCriteria(1)
.Type = xlConditionValueLowestValue
With .FormatColor
.Color = vbGreen
.TintAndShade = -0.25
End With
End With
' Format the second color
With cs1.ColorScaleCriteria(2)
.Type = xlConditionValueHighestValue
With .FormatColor
.Color = vbBlue
.TintAndShade = 0
End With
End With
'Do second half
Dim rng2 As Range
Set rng2 = Range(Cells(inthalf + 1, 1), Cells(intcount, 1))
' Add a 2-color scale.
Dim cs2 As ColorScale
Set cs2 = rng2.FormatConditions.AddColorScale(ColorScaleType:=2)
' Format the third color
With cs2.ColorScaleCriteria(1)
.Type = xlConditionValueLowestValue
With .FormatColor
.Color = vbRed
.TintAndShade = -0.25
End With
End With
' Format the fourth color
With cs2.ColorScaleCriteria(2)
.Type = xlConditionValueHighestValue
With .FormatColor
.Color = vbYellow
.TintAndShade = 0
End With
End With
Application.ScreenUpdating = True
End Sub