What can you learn here?
- ramp color scales
- gradient between colors
- Use a ramp library
Generalized Color Ramps
If you read A tagCloud in Outlook, How to create a tag cloud or Create a heatmap in Excel you would have seen reference to a heatmap scale. This is specific form of color ramp that calculates a color ranging from blue through red depending on it’s value compared to the rest of the range it is in. Here we will look at creating a generalized color ramp, and an extensible VBA library of useful ramps.
As usual this code is implemented in the cDataSet.xlsm module downloadable from Download Complete Projects. There is a Google Apps Script version of this library if you are a Google Docs user. See Charts and color ramps for how to make interesting charts using color ramps
If you are interested in creating maps or shapes with heatmaps, here’s a one liner to do it.
How it works
You provide 2 or more colors, and the difference between their red, green and blue component values is calculated. A single RGB color is provided that you can use to represent the input value.
Example Color ramps
Here is the code to produce the ramps shown above.
Public Sub testHeatMapScaleRamp() Dim m As Long, n As Long, r As Range Set r = Sheets("heatmapramp").Range("a1") r.Worksheet.Cells.Interior.color = vbWhite Const npoints = 200 For m = 0 To npoints r.Offset(, m).Interior.color = _ rampLibraryRGB("heatmap", 0, npoints, m) r.Offset(1, m).Interior.color = _ rampLibraryRGB("heatmaptowhite", 0, npoints, m) r.Offset(2, m).Interior.color = _ rampLibraryRGB("blacktowhite", 0, npoints, m) r.Offset(3, m).Interior.color = _ rampLibraryRGB("whitetoblack", 0, npoints, m) r.Offset(4, m).Interior.color = _ rampLibraryRGB("hotinthemiddle", 0, npoints, m) r.Offset(5, m).Interior.color = _ rampLibraryRGB("candylime", 0, npoints, m) r.Offset(6, m).Interior.color = _ rampLibraryRGB("heatcolorblind", 0, npoints, m) r.Offset(7, m).Interior.color = _ rampLibraryRGB("gethotquick", 0, npoints, m) r.Offset(8, m).Interior.color = _ rampLibraryRGB("greensweep", 0, npoints, m) Next mEnd SubHere is the colorramp library defining them
Public Function rampLibraryRGB(sName As String, min As Variant, _
max As Variant, Value As Variant, _
Optional brighten As Double = 0) As Long
Select Case Trim(LCase(sName))
Case “heatmaptowhite”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlue, vbGreen, vbYellow, vbRed, vbWhite), , _
brighten)
Case “heatmap”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlue, vbGreen, vbYellow, vbRed), , _
brighten)
Case “blacktowhite”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlack, vbWhite), , brighten)
Case “whitetoblack”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbWhite, vbBlack), , brighten)
Case “hotinthemiddle”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlue, vbGreen, vbYellow, vbRed, _
vbYellow, vbGreen, vbBlue), , brighten)
Case “candylime”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(RGB(255, 77, 121), RGB(255, 121, 77), _
RGB(255, 210, 77), RGB(210, 255, 77)), , _
brighten)
Case “heatcolorblind”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlack, vbBlue, vbRed, vbWhite), , brighten)
Case “gethotquick”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlue, vbGreen, vbYellow, vbRed), _
Array(0, 0.1, 0.25, 1), brighten)
Case “greensweep”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(RGB(153, 204, 51), RGB(51, 204, 179)), , _
brighten)
Case “terrain”
rampLibraryRGB = colorRamp(min, max, Value, _
Array(vbBlack, RGB(0, 46, 184), RGB(0, 138, 184), _
RGB(0, 184, 138), _
RGB(138, 184, 0), RGB(184, 138, 0), _
RGB(138, 0, 184), vbWhite), , _
brighten)
Case Else
Debug.Assert False
End Select
End Function
ColorRamp Function
Intermediate colors
Aside from the min, max and value that you want the color calculated for, you can also provide an array of as many colors as you want. colorRamp will use these to ‘pass through’ – so for example a heatmap would be Array(vbBlue, vbGreen, vbYellow, vbRed). To get the exact effect you want, just add some more intermediate colors.
Ramp speed
By default, the rate at which the colors evolve between intermediate or ‘milestone’ colors is evenly divided. However if you wanted to modify that – for example the library entry ‘gethotquick’, spends longer on the red tone colors than on the blue – you can specify the ramp up speed for each milestone color as below –
Case "gethotquick" rampLibraryRGB = colorRamp(min, max, Value, _ Array(vbBlue, vbGreen, vbYellow, vbRed), _ Array(0, 0.1, 0.25, 1))Code
Here us the code for the colorRamp function.
Public Function colorRamp(min As Variant, _
max As Variant, Value As Variant, _
Optional mileStones As Variant, _
Optional fractionStones As Variant, _
Optional brighten As Double = 1)
‘ create a value from a colorramp going through the array of milestones
Dim spread As Double, ratio As Double, red As Double, _
green As Double, blue As Double, j As Long, _
lb As Long, ub As Long, cb As Long, r As Double, i As Long
‘—-defaults and set up milestones on ramp
Dim ms() As Long
Dim fs() As Double
If IsMissing(mileStones) Then
ReDim ms(0 To 4)
ms(0) = vbBlue
ms(1) = vbGreen
ms(2) = vbYellow
ms(3) = vbRed
ms(4) = vbWhite
Else
ReDim ms(0 To UBound(mileStones) – LBound(mileStones))
j = 0
For i = LBound(mileStones) To UBound(mileStones)
ms(j) = mileStones(i)
j = j + 1
Next i
End If
‘ tedious this is
lb = LBound(ms)
ub = UBound(ms)
cb = ub – lb + 1
‘ only 1 milestone – thats the color
If cb = 1 Then
colorRamp = ms(lb)
Exit Function
End If
If Not IsMissing(fractionStones) Then
If UBound(fractionStones) – LBound(fractionStones) <> _
cb – 1 Then
MsgBox (“no of fractions must equal number of steps”)
Exit Function
Else
ReDim fs(lb To ub)
j = lb
For i = LBound(fractionStones) To UBound(fractionStones)
fs(j) = fractionStones(i)
j = j + 1
Next i
End If
Else
ReDim fs(lb To ub)
For i = lb + 1 To ub
fs(i) = i / (cb – 1)
Next i
End If
‘spread of range
spread = max – min
Debug.Assert spread >= 0
ratio = (Value – min) / spread
Debug.Assert ratio >= 0 And ratio <= 1
‘ find which slot
For i = lb + 1 To ub
If ratio <= fs(i) Then
r = (ratio – fs(i – 1)) / (fs(i) – fs(i – 1))
red = rgbRed(ms(i – 1)) + (rgbRed(ms(i)) – rgbRed(ms(i – 1))) * r
blue = rgbBlue(ms(i – 1)) + (rgbBlue(ms(i)) – rgbBlue(ms(i – 1))) * r
green = rgbGreen(ms(i – 1)) + (rgbGreen(ms(i)) – rgbGreen(ms(i – 1))) * r
colorRamp = RGB(lumRGB(red, brighten), _
lumRGB(green, brighten), _
lumRGB(blue, brighten))
Exit Function
End If
Next i
Debug.Assert False
End Function
Private Function lumRGB(rgbCom As Double, brighten As Double) As Double
Dim x As Double
x = rgbCom * brighten
If x > 255 Then x = 255
If x < 0 Then x = 0
lumRGB = x
End Function
Public Function rgbRed(rgbColor As Long) As Long
rgbRed = rgbColor Mod &H100
End Function
Public Function rgbGreen(rgbColor As Long) As Long
rgbGreen = (rgbColor \ &H100) Mod &H100
End Function
Public Function rgbBlue(rgbColor As Long) As Long
rgbBlue = (rgbColor \ &H10000) Mod &H100
End Function
Related pages