Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Playing around with heatmaps. http://ramblings.mcpher.com
Option Explicit
' v2.06 - 5083132
Private Sub runMap()
applyHeatMapToRange Range("sankey!e2:e41")
End Sub
Private Sub colorThemePlay()
Dim r As Range, i As Long, j As Long, p As colorProps
' 1= background1, 2= text1, 3 = background2, 4 = text2, 5-10 accent1-6
Set r = firstCell(wholeSheet("colorTheme"))
Application.Calculation = xlCalculationManual
For i = 1 To 10
With r.Offset(1, i - 1)
p = makeColorProps(.Interior.color)
.value = p.htmlHex
.Font.color = p.textColor
End With
With r.Offset(3, i - 1)
For j = 1 To 5
With .Offset(j - 1)
p = makeColorProps(.Interior.color)
.Font.color = p.textColor
.value = .Interior.TintAndShade
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(6 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.htmlHex
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(12 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.hue
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(18 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.saturation
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(24 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.lightness
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(30 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.value
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(36 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.aStar
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(42 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.bStar
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(48 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.cStar
End With
Next j
For j = 1 To 5
p = makeColorProps(.Offset(j - 1).Interior.color)
With .Offset(54 + j - 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.hStar
End With
Next j
End With
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub checkit()
Dim i As Long
For i = vbBlack To vbWhite
Debug.Assert i = lchToRgb(makeColorProps(i))
Next i
End Sub
Public Sub getSomePalettes()
Dim n As Long, r As Range, ncells As Long, p As colorProps, swatchSize As Long, _
a() As colorProps, i As Long, models As Variant, prop As Variant, _
done As Long, j As Long, k As Long, rowHeight As Double, spaceHeight As Double, _
columnWidth As Double, spaceWidth As Double, rowOff As Long, colOff As Long, t As Long
Set r = firstCell(wholeSheet("palette"))
models = Array("lch", "hsl")
prop = Array("hue", "lightness", "saturation")
ncells = 9
swatchSize = 5
done = 0
rowHeight = 20
columnWidth = 6
spaceHeight = rowHeight / 5
spaceWidth = columnWidth / 5
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Randomize
'--------create some random colors to test against, and format worksheet
For n = 1 To ncells
With r.Offset((n - 1) * (2 + arrayLength(models)) + 1, 0).Resize(arrayLength(models) + 1)
' basic section for this random color
''p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
p = makeColorProps(htmlHexToRgb(r.Offset(1 + (n - 1) * 4, 0).Resize(1, 1).value))
.Interior.color = p.rgb
.Font.color = p.textColor
.value = Empty
.rowHeight = rowHeight
' name the models
For k = LBound(models) To UBound(models)
.Resize(1, 1).Offset(k - LBound(models) + 1).value = models(k)
Next k
.Resize(arrayLength(models), 1).Offset(1).BorderAround xlContinuous
' add a break line with reference color
With .Resize(1, arrayLength(prop) * (swatchSize + 1) + 1)
.Interior.color = p.rgb
.Font.color = p.textColor
.columnWidth = columnWidth
With .Resize(, 1)
.value = p.htmlHex
.columnWidth = columnWidth * 3
End With
.Offset(0, 0).BorderAround xlContinuous
End With
' add column breaks between props and name them
For k = LBound(prop) To UBound(prop)
With .Resize(, 1).Offset(, 1 + (swatchSize + 1) * (k - LBound(prop)))
.columnWidth = spaceWidth
.Resize(1, 1).Offset(, 1).value = prop(k)
End With
Next k
' add a break line after
With .Offset(arrayLength(models) + 1).Resize(1)
.rowHeight = spaceHeight
.Interior.color = vbWhite
.Font.color = vbBlack
.value = Empty
End With
End With
Next n
'------------create various palettes
For k = LBound(models) To UBound(models)
For j = LBound(prop) To UBound(prop)
For n = 1 To ncells
' this is the header row/narrow column
rowOff = 1 + (n - 1) * (2 + arrayLength(models))
colOff = 1 + (1 + swatchSize) * (j - LBound(prop))
With r.Offset(rowOff, colOff)
a = makeAPalette(.Interior.color, CStr(models(k)), _
CStr(prop(j)), swatchSize)
With .Offset(k - LBound(models) + 1)
.Interior.color = vbWhite
For i = LBound(a) To UBound(a)
With .Offset(, 1 + i - LBound(a))
.Interior.color = a(i).rgb
.value = rgbToHTMLHex(a(i).rgb)
End With
.Offset(, 1).Resize(, swatchSize).BorderAround xlContinuous
Next i
End With
End With
Next n
Next j
Next k
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function makeAPalette(rgbColor As Long, Optional model As String = "lch", _
Optional iType As String = "hue", Optional howMany As Long = 5) As colorProps()
' return an array of palettable colors
Dim g As Double, a() As colorProps, p As colorProps, _
i As Long, h As Double, top As Double, pv As String
ReDim a(1 To howMany)
If iType = "hue" Then
top = 360
Else
top = 100
End If
' step
g = top / howMany
p = makeColorProps(rgbColor)
If iType = "hue" Then
If model = "lch" Then
h = p.hStar
pv = "hStar"
Else
h = p.hue
pv = "hue"
End If
ElseIf iType = "saturation" Then
If model = "lch" Then
h = p.cStar
pv = "cstar"
Else
h = p.saturation
pv = "saturation"
End If
Else
If model = "lch" Then
h = p.LStar
pv = "lstar"
Else
h = p.lightness
pv = "lightness"
End If
End If
For i = 1 To howMany
If h > top Then h = h - top
If model = "lch" Then
If iType = "hue" Then
p.hStar = h
ElseIf iType = "saturation" Then
p.cStar = h
Else
p.LStar = h
End If
p = makeColorProps(lchToRgb(p))
Else
If iType = "hue" Then
p.hue = h
ElseIf iType = "saturation" Then
p.saturation = h
Else
p.lightness = h
End If
p = makeColorProps(hslToRgb(p))
End If
a(i) = p
h = h + g
Next i
sortColorProp a, LBound(a), UBound(a), pv
makeAPalette = a
End Function
Public Sub SeedSomeColors()
Dim r As Range, n As Long, ncells As Long, ds As cDataSet, t As Long, dc As cCell, _
dr As cDataRow, p As colorProps, a As Variant, i As Long
Set r = firstCell(wholeSheet("comparecolors"))
ncells = 30
Application.Calculation = xlCalculationManual
Randomize
' create some random colors to test against
For n = 1 To ncells
With r.Offset(n, 0)
p = makeColorProps(Int((vbWhite - vbBlack + 1) * Rnd + vbBlack))
.Interior.color = p.rgb
.Font.color = p.textColor
.value = p.htmlHex
End With
Next n
' now look in the colortable
Set ds = getcolorMap()
' cycle through various schemes
a = Array("", "pms", "pfh", "dulux", "htm")
For i = LBound(a) To UBound(a)
For n = 1 To ncells
t = r.Offset(n, 0).Interior.color
Set dc = getClosestColorMap(ds, t, CStr(a(i)))
If Not dc Is Nothing Then
With r.Offset(n, 1 + i - LBound(a))
p = makeColorProps(htmlHexToRgb(dc.value))
.value = ds.value(dc.row, "name")
.Interior.color = p.rgb
.Font.color = p.textColor
End With
End If
Next n
Next i
Application.Calculation = xlCalculationAutomatic
ds.tearDown
End Sub
Private Function getClosestColorMap(ds As cDataSet, target As Long, _
Optional scheme As String = vbNullString) As cCell
Dim dc As cCell, dmin As Double, d As Double, dr As cDataRow
Set dc = Nothing
For Each dr In ds.rows
If (scheme = vbNullString Or dr.value("scheme") = scheme) Then
d = compareColors(target, htmlHexToRgb(dr.value("hex")))
If dc Is Nothing Or d < dmin Then
dmin = d
Set dc = dr.cell("hex")
End If
End If
Next dr
Set getClosestColorMap = dc
End Function
Public Sub doughnutExample()
Dim dsout As New cDataSet
createHotDoughnutChart _
dsout.populateData(wholeSheet("doughnut"), , , , , , True), "heatmap", , , , , , , , , , False
dsout.tearDown
End Sub
Public Sub doughnutPantoneExample()
Dim dc As cCell, aYear As Variant, dsdata As cDataSet, dMap As cDataSet
' we'll use the data columns to create an array of color ramps
' based on the colors for each year
Set dsdata = getDsQuick("pantonedoughnut")
Set dMap = getcolorMap()
With dsdata
ReDim aYear(1 To .columns.count - 1)
For Each dc In .headings
If dc.column <> 1 Then
aYear(dc.column - 1) = getPantoneColorsOfTheYear(dc.value, , dMap)
End If
Next dc
' now doughnut it - we're going to use the 2013 color ramp as outside labels.
createHotDoughnutChart _
dsdata, "heatmap", , 10, aYear, , , _
getPantoneColorsOfTheYear(2013, , dMap), , , , False, vbBlack
.tearDown
End With
dMap.tearDown
End Sub
Public Sub doughnutPantoneOne()
Dim dc As cCell, aYear As Variant, dsdata As cDataSet
' we'll use the data columns to create an array of color ramps
' based on the colors for each year
Set dsdata = getDsQuick("pantonedoughnut")
aYear = getPantoneColorsOfTheYear(2013)
With dsdata
' now doughnut it - we're going to use the 2013 color ramp as outside labels.
createHotDoughnutChart _
dsdata, "heatmap", , , aYear, , , _
aYear, , , , False
.tearDown
End With
End Sub
Public Sub makePantoneWinners()
makeRampedGeneral "swatches", getPantoneColorsOfTheYear(), _
getPantoneColorsOfTheYear(, "name"), "Pantone colors of the year 2013 - 2000", 7
End Sub
Public Sub makePantone2013()
makeRampedGeneral "swatches", getPantoneColorsOfTheYear(2013), _
getPantoneColorsOfTheYear(2013, "name"), "Pantone 2013 colors", 7
End Sub
Public Sub makePantoneAllYears()
Dim u As Collection, cc As cCell, dMap As cDataSet, nextRange As Range
Set dMap = getcolorMap()
' do a row for winners
Set nextRange = makeRampedGeneral("swatches", getPantoneColorsOfTheYear(, , dMap), _
getPantoneColorsOfTheYear(, "name", dMap), "Pantone colors of the year 2013 - 2004", 7)
' the known years are here
With pantoneYearTable()
Set u = .column("year").uniqueValues
For Each cc In u
Set nextRange = makeRampedGeneral("swatches", getPantoneColorsOfTheYear(cc.value, , dMap), _
getPantoneColorsOfTheYear(cc.value, "name", dMap), _
"Pantone " & cc.toString & " colors", 7, , , nextRange)
Next cc
.tearDown
End With
dMap.tearDown
End Sub
Public Function makeRampedGeneral(sheetName As String, colorList As Variant, _
nameList As Variant, title As String, _
Optional width As Long = 7, _
Optional pointsPerMilestone As Long = 50, _
Optional fontSize As Variant = 10, _
Optional lastRange As Range = Nothing) As Range
Dim r As Range, i As Long, totalPoints As Long, height As Long, rNextRange As Range
Application.ScreenUpdating = False
' going to make some color swatches
Set r = firstCell(wholeSheet(sheetName))
If (lastRange Is Nothing) Then
With r.Worksheet.Cells
.clear
End With
Else
Set r = firstCell(lastCell(lastRange).Offset(1).EntireRow)
End If
' how many columns in total
totalPoints = arrayLength(colorList) * pointsPerMilestone
height = width * 6
Set rNextRange = r.Resize(5, totalPoints)
With rNextRange
.columnWidth = width / pointsPerMilestone
.rowHeight = height
.Font.size = fontSize
.Interior.color = vbWhite
End With
' small space betwen swatches
With rNextRange
.Offset(1).Resize(1).rowHeight = height / 20
With .Offset(.rows.count - 2).Resize(1)
.rowHeight = height / 20
.Interior.color = vbBlack
End With
.Offset(.rows.count - 1).Resize(1).rowHeight = height / 10
End With
' ramp with intermediate colors
For i = 1 To totalPoints
With r.Offset(, i - 1)
.Interior.color = rampLibraryRGB(colorList, 1, totalPoints, i)
End With
Next i
' add a title
With r.Resize(1, 1)
.value = title
.Font.color = makeColorProps(.Interior.color).textColor
End With
' now contrast that with the non ramped
For i = 1 To arrayLength(colorList)
With r.Resize(1, pointsPerMilestone).Offset(2, (i - 1) * pointsPerMilestone)
.Interior.color = colorList(i)
With .Resize(1, 1)
.Font.color = makeColorProps(.Interior.color).textColor
.value = nameList(i + LBound(nameList) - 1)
End With
End With
Next i
Application.ScreenUpdating = True
Set makeRampedGeneral = rNextRange
End Function
Public Sub makeRampedPantone()
Dim r As Range, colorList As Variant, i As Long, _
self As cDataSet, totalPoints As Long, nameList As Variant
' going to make some color swatches
Set r = firstCell(wholeSheet("swatches"))
r.Worksheet.Cells.clear
r.Worksheet.Cells.Interior.color = vbWhite
' various parameters for layout
Const width = 72
Const height = 64
Const pointsPerMilestone = 50
' get pantone spring collection colors
colorList = getPantoneColorsOfTheYear(2013)
nameList = getPantoneColorsOfTheYear(2013, "name")
totalPoints = arrayLength(colorList) * pointsPerMilestone
With r.Resize(2, totalPoints)
.columnWidth = width / totalPoints
.rowHeight = height
End With
' ramp with intermediate colors
For i = 1 To totalPoints
With r.Offset(, i - 1)
.Interior.color = rampLibraryRGB(colorList, 1, totalPoints, i)
End With
Next i
' add a title
With r.Resize(1, 1)
.value = "Pantone 2013 Spring Colors"
.Font.color = makeColorProps(.Interior.color).textColor
End With
' now contrast that with the non ramped
For i = 1 To arrayLength(colorList)
With r.Resize(1, pointsPerMilestone).Offset(1, (i - 1) * pointsPerMilestone)
.Interior.color = colorList(i)
With .Resize(1, 1)
.Font.color = makeColorProps(.Interior.color).textColor
.value = nameList(i + LBound(nameList) - 1)
End With
End With
Next i
End Sub
Public Sub makeRampedSwatches()
Dim r As Range, nameList As Variant, i As Long, _
ramp As Variant, self As cDataSet, totalPoints As Long
' going to make some color swatches
Set r = firstCell(wholeSheet("swatches"))
r.Worksheet.Cells.clear
r.Worksheet.Cells.Interior.color = vbWhite
' going to use some dulux names
Const schemePrefix = "dulux-"
Const width = 72
Const height = 64
Const pointsPerMilestone = 50
' get the color map table
With getcolorMap()
' refer to the dataset for later
Set self = .self
' these are our colors
nameList = Array( _
"charred chocolate", _
"charred clay", _
"cheater", _
"cheesy grin", _
"chenille" _
)
' lets get the actual colors
ReDim ramp(1 To arrayLength(nameList))
For i = LBound(nameList) To UBound(nameList)
ramp(i + 1 - LBound(nameList)) = .value(schemePrefix & nameList(i), "rgb")
Next i
totalPoints = arrayLength(nameList) * pointsPerMilestone
With r.Resize(2, totalPoints)
.columnWidth = width / totalPoints
.rowHeight = height
End With
' ramp with intermediate colors
For i = 1 To totalPoints
With r.Offset(, i - 1)
.Interior.color = rampLibraryRGB(ramp, 1, totalPoints, i)
End With
Next i
' add a title
With r.Resize(1, 1)
.value = "ramped swatch"
.Font.color = makeColorProps(.Interior.color).textColor
End With
' now contrast that with the non ramped
For i = 1 To arrayLength(nameList)
With r.Resize(1, pointsPerMilestone).Offset(1, (i - 1) * pointsPerMilestone)
.Interior.color = ramp(i)
With .Resize(1, 1)
.Font.color = makeColorProps(.Interior.color).textColor
.value = nameList(i + LBound(nameList) - 1)
End With
End With
Next i
'cleanup
.tearDown
End With
End Sub
Public Sub makeSimpleSwatches()
Dim r As Range, nameList As Variant, i As Long, self As cDataSet
' going to make some color swatches
Set r = firstCell(wholeSheet("swatches"))
r.Worksheet.Cells.clear
' going to use some dulux names
Const schemePrefix = "dulux-"
' get the color map table
With getcolorMap()
' refer to the dataset for later
Set self = .self
' these are our colors
nameList = Array( _
"charred chocolate", _
"charred clay", _
"cheater", _
"cheesy grin", _
"chenille" _
)
' look up the colors, get and good text colors
For i = LBound(nameList) To UBound(nameList)
With r.Offset(, i - LBound(nameList))
.Interior.color = self.value(schemePrefix & nameList(i), "rgb")
.Font.color = makeColorProps(.Interior.color).textColor
.value = nameList(i)
End With
Next i
'cleanup
.tearDown
End With
End Sub
Private Function getDsQuick(name As String) As cDataSet
Dim ds As cDataSet
Set ds = New cDataSet
Set getDsQuick = ds.load(name)
End Function
Public Sub heatMapExample()
Dim dsout As New cDataSet
createSurfaceChart _
dsout.populateData(wholeSheet("matrixout"), , "matrixout", True, , , True, "matrix"), _
"heatmap"
dsout.tearDown
End Sub
Public Sub colorRampVisualize()
Dim dsout As New cDataSet
createSurfaceChart _
dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
"crampChart", xlSurfaceTopView, 200, "heatmaptowhite", False
dsout.tearDown
End Sub
Public Sub colorRampTerrain()
Dim dsout As New cDataSet
createSurfaceChart _
dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
"crampChart", xlSurfaceTopView, 200, "terrain", False, 1.3
dsout.tearDown
End Sub
Public Sub pantoneYearsVisualize()
Dim dsout As New cDataSet
createSurfaceChart _
dsout.populateData(wholeSheet("crampviz"), , , True, , , True, "y/x"), _
"crampChart", xlSurfaceTopView, 400, getPantoneColorsOfTheYear(2013), False
dsout.tearDown
End Sub
Public Function getPantoneColorsOfTheYear(Optional yearSelect As Variant = Empty, _
Optional columnName As String = "hex", Optional colorMapSet As cDataSet = Nothing) As Variant
Dim ds As cDataSet, dMap As cDataSet, dr As cDataRow, colors As Variant, n As Long, c As String
Set ds = New cDataSet
' using the home and fashion pantone set
Const colorSetPrefix = "pfh-"
ReDim colors(1 To 1)
If Not colorMapSet Is Nothing Then
Set dMap = colorMapSet
Else
Set dMap = getcolorMap()
End If
' get the colors for the list of colors of the year and return them as an array
With pantoneYearTable()
n = 0
For Each dr In .rows
If (IsEmpty(yearSelect) And .isCellTrue(dr.row, "winner")) Or _
(dr.value("year") = yearSelect) Then
n = n + 1
ReDim Preserve colors(1 To n)
c = dMap.toString(makeKey(colorSetPrefix & dr.toString("name")), columnName)
If (columnName = "hex") Then
colors(n) = htmlHexToRgb(c)
ElseIf columnName = "name" Then
colors(n) = dr.toString("name")
End If
End If
Next dr
.tearDown
End With
If colorMapSet Is Nothing Then
dMap.tearDown
End If
getPantoneColorsOfTheYear = colors
End Function
Public Function pantoneYearTable() As cDataSet
' get the table with the pantone colors of the year
Dim ds As cDataSet
Set ds = New cDataSet
Set pantoneYearTable = ds.populateData(wholeSheet("colorsoftheyear"), , , , , , True)
End Function
Public Function getcolorMap(Optional curt As Boolean = True) As cDataSet
Dim ds As cDataSet
Set ds = New cDataSet
If curt Then
ds.populateData toEmptyRow(wholeSheet("colorTable").Resize(, 3)), , , True, , , , "name"
Else
ds.populateData wholeSheet("colorTable"), , , True, , , True, "name"
End If
Set getcolorMap = ds
End Function
Public Sub colorMap()
Dim dr As cDataRow, p As colorProps
With getcolorMap(False)
' get all we know about each pantone color
For Each dr In .rows
With dr
' get all we know about this color
p = makeColorProps(htmlHexToRgb(.toString("hex")))
.cell("magenta").value = p.magenta
.cell("yellow").value = p.yellow
.cell("black").value = p.black
.cell("cyan").value = p.cyan
.cell("red").value = p.red
.cell("green").value = p.green
.cell("blue").value = p.blue
.cell("htmlHex").value = p.htmlHex
.cell("rgb").value = p.rgb
.cell("textcolor").value = p.textColor
.cell("luminance").value = p.luminance
.cell("contrastRatio").value = p.contrastRatio
.cell("value").value = p.value
.cell("hue").value = p.hue
.cell("saturation").value = p.saturation
.cell("lightness").value = p.lightness
.cell("x").value = p.x
.cell("y").value = p.y
.cell("z").value = p.z
.cell("lstar").value = p.LStar
.cell("astar").value = p.aStar
.cell("bstar").value = p.bStar
.cell("cstar").value = p.cStar
.cell("hstar").value = p.hStar
' color the row with and use a friendly text color
.where.Interior.color = p.rgb
.where.Font.color = p.textColor
End With
Next dr
.bigCommit
.tearDown
End With
End Sub
Public Sub colorRampElevation()
Dim dsout As New cDataSet, ds As New cDataSet
' the formula data contains rand() function so it will recalculate-
Application.Calculate
' copy the values elsewhere so it doesnt happen again and change the finished chart
ds.populateData(wholeSheet("elevate"), , , , , , True).bigCommit _
whereIsThis("straightcopy!a1"), True
'base on the copied data
createSurfaceChart _
dsout.populateData(wholeSheet("straightcopy"), , "elevate", True, , , True, "lat/lon"), _
"top", , 400, "terrainnosea", False, , False
dsout.tearDown
ds.tearDown
End Sub
Public Sub testheatmapscale()
Dim dsout As cDataSet, dc As cCell, c As colorProps
Dim mx As Variant, mn As Variant, dr As cDataRow
Set dsout = New cDataSet
With dsout.populateData(wholeSheet("heatmapcolors"), , , , , , True)
mx = .max
mn = .min
' do the heading as a heatmap scale
For Each dc In .headingRow.headings
dc.where.Interior.color = colorRamp(1, .columns.count, dc.column)
Next dc
'now the data
For Each dr In .rows
For Each dc In dr.columns
If (Not IsEmpty(dc.value)) Then
c = makeColorProps(rampLibraryRGB("heatmap", mn, mx, dc.value))
dc.where.Interior.color = c.rgb
dc.where.Font.color = c.textColor
End If
Next dc
Next dr
End With
dsout.tearDown
End Sub
Public Sub testHeatMapScaleRamp()
Dim m As Long, n As Long, r As Range, aList As Variant, _
vList As Variant, i As Long, ds As cDataSet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set r = Sheets("heatmapramp").Range("a1")
r.Worksheet.Cells.clear
' these are the library entries we'll use
aList = Array("pantone2013fashion", "pantone2012fashion", "pantone2011fashion", _
"pantone2010fashion", "pantonecolorsoftheyear", _
"heatmap", "heatmaptowhite", "blacktowhite", "whitetoblack", "hotinthemiddle", _
"candylime", "heatcolorblind", "gethotquick", "greensweep", "greendollar")
' demonstrate mixture of dynamically created and library entry ramps
vList = aList
Set ds = getcolorMap()
vList(LBound(vList)) = getPantoneColorsOfTheYear(2013, , ds)
vList(LBound(vList) + 1) = getPantoneColorsOfTheYear(2012, , ds)
vList(LBound(vList) + 2) = getPantoneColorsOfTheYear(2011, , ds)
vList(LBound(vList) + 3) = getPantoneColorsOfTheYear(2010, , ds)
vList(LBound(vList) + 4) = getPantoneColorsOfTheYear(, , ds)
Const npoints = 200
For i = LBound(aList) To UBound(aList)
For m = 0 To npoints
r.Offset(i - LBound(aList), m).Interior.color = _
rampLibraryRGB(vList(i), 0, npoints, m)
Next m
'label and choose a decent text color
With r.Offset(i - LBound(aList), 0)
.value = aList(i)
.Font.color = makeColorProps(.Interior.color).textColor
End With
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Function findInCollection(col As Collection, sVal As Variant) As Long
Dim n As Long
For n = 1 To col.count
If makeKey(col(n).value) = makeKey(sVal) Then
findInCollection = n
Exit Function
End If
Next n
findInCollection = 0
End Function
Private Function knownShape(col As Variant, sname As String) As Long
Dim n As Long, s As shape
n = 0
For Each s In col
n = n + 1
If makeKey(s.name) = makeKey(sname) Then
knownShape = n
Exit Function
End If
Next s
End Function
Sub makeSkillPoleMapFilterProc(Optional useCurrent As Boolean = False)
Dim dst As cDataSet, ds As cDataSet, colTarget As Collection, _
dr As cDataRow, cc As cCell, n As Long, _
a() As Long, s As shape, mn As Long, mx As Long, ck As String, cMap As New Collection, _
sname As String, st As String
Const colorEmpty = 7897995
' get data
Set dst = New cDataSet
dst.populateData Range("completedata"), , , , , , True, , , , True
st = "shortTarget"
If useCurrent Then st = "shortCurrent"
Set colTarget = dst.column(st).uniqueValues(eSortAscending)
ReDim a(1 To colTarget.count)
For Each dr In dst.rows
If Not dr.hidden Then
' here's one - is this a known shape?
ck = makeKey(dr.value(st))
sname = "S_" & ck
With Sheets("world map")
If isinCollection(.Shapes, sname) Then
' we'll take it
If (isinCollection(cMap, ck)) Then
n = knownShape(cMap, sname)
Else
cMap.add .Shapes(sname), ck
n = knownShape(cMap, sname)
End If
a(n) = a(n) + 1
Else
MsgBox (sname & " map shape not found")
End If
End With
End If
Next dr
mn = -1
mx = -1
' get max/min
For n = LBound(a) To UBound(a)
If (a(n) > mx Or mx = -1) Then mx = a(n)
If (a(n) < mn Or mn = -1) Then mn = a(n)
Next n
' add heatmap shapes
For n = 1 To cMap.count
With cMap(n)
.Fill.ForeColor.rgb = heatmapColor(mn, mx, a(n))
End With
Next n
End Sub
Public Function shapeRamp(ds As cDataSet, wNameWhereShapesAre As String, _
Optional dataColumnName As String = "data", _
Optional shapeColumnName As String = "shapes", _
Optional screenTipColumnName As String = vbNullString, _
Optional unknownShapeName As String = vbNullString, _
Optional unusedShapeColor As Long = 7897995, _
Optional rampName As String = "heatmap", _
Optional showValueAsTip As Boolean = True, _
Optional complain As Boolean = True, _
Optional unusedShapeColorApply As Boolean = False) As cDataSet
' this will create a colorramp for a data set on a group of shapes (usually a choropleth map)
Dim ws As Worksheet, dr As cDataRow, workwith As Long, _
co As Collection, n As Long, sname As String, s As shape, _
mn As Variant, mx As Variant, u As Variant, bu As Boolean, a() As Variant, t As String
' check all args are good
Set ws = sheetExists(wNameWhereShapesAre)
If Not (ds.headingRow.validate(True, dataColumnName, shapeColumnName) And _
Not ws Is Nothing) Then
Exit Function
End If
If screenTipColumnName <> vbNullString Then
If Not (ds.headingRow.validate(True, screenTipColumnName)) Then
Exit Function
End If
End If
If (unknownShapeName <> vbNullString And findShape(unknownShapeName, ws) Is Nothing) Then
MsgBox ("shape " & unknownShapeName & " doesnt exist")
Exit Function
End If
' anything to do?
workwith = ds.visibleRowsCount
If workwith <= 0 Then
MsgBox "no data visible - have you filtered too much?"
Exit Function
End If
' ok lets go - delete any hyperlinks (which are used for screentips)
clearHyperLinks ws
' all shapes to accumulate
Set co = ds.column(shapeColumnName).uniqueValues
ReDim a(1 To co.count) As Variant
bu = False
For Each dr In ds.rows
sname = dr.toString(shapeColumnName)
n = findInCollection(co, sname)
a(n) = a(n) + dr.value(dataColumnName)
If (findShape(sname, ws) Is Nothing) Then
u = u + a(n)
bu = True
End If
Next dr
' min and max may need modified if there were some unknowns
mx = ds.column(dataColumnName).max
mn = ds.column(dataColumnName).min
If bu Then
If u > mx Then mx = u
If u < mn Then mn = u
End If
' default coloration
If unusedShapeColorApply Then
For Each s In ws.Shapes
s.Fill.ForeColor.rgb = unusedShapeColor
Next s
If bu Then
findShape(unknownShapeName, ws).Fill.ForeColor.rgb = unusedShapeColor
End If
End If
' now plot
For n = LBound(a) To UBound(a)
Set s = findShape(co(n).toString, ws)
If (Not s Is Nothing) Then
s.Fill.ForeColor.rgb = rampLibraryRGB(rampName, mn, mx, a(n))
t = vbNullString
If screenTipColumnName <> vbNullString Then
t = ds.toString(co(n).row, screenTipColumnName)
End If
If showValueAsTip Or t <> vbNullString Then
ws.Hyperlinks.add s, "", "", ScreenTip:=t & "(" & CStr(a(n)) & ")"
End If
Else
If (complain) Then MsgBox ("Shape doesnt exist " & co(n).toString)
End If
Next n
'unknown plot?
If (unknownShapeName <> vbNullString And bu) Then
Set s = findShape(unknownShapeName, ws)
s.Fill.ForeColor.rgb = rampLibraryRGB(rampName, mn, mx, u)
t = "Unknown shapes"
If showValueAsTip Or t <> vbNullString Then
ws.Hyperlinks.add s, "", "", ScreenTip:=t & "(" & CStr(u) & ")"
End If
End If
Set shapeRamp = ds
End Function
Private Function makeSomeTables()
Dim styles As String
styles = "color,background-color,font-size"
tableToHtml "colorTable", , , styles, "google"
tableToHtml "colorTable", , 20, styles, "google"
tableToHtml "colorTable", , 20, styles, "static"
tableToHtml "inputData", , , , "static"
tableToHtml "inputData"
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.