What can you learn here?

  • ramp color scales
  • gradient between colors
  • Use a ramp library

Generalized Color Ramps

If you read A tagCloud in OutlookHow 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 m
End Sub
 
Here 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