useful chart stuff - for more info see http://ramblings.mcpher.com

usefulChartStuff.vba

Option Explicit
' v2.01 -

Public Function createSurfaceChart(ds As cDataSet, n As String, _
                    Optional xlt As Long = xlSurface, _
                    Optional targetLegends As Long = 0, _
                    Optional colorRampName As Variant = "heatmap", _
                    Optional showLegend As Boolean = False, _
                    Optional brighten As Double = 1, _
                    Optional showAxis As Boolean = True) As Chart
    Dim cht As Chart, s As Series, dr As cDataRow, dc As cCell, sc As Double, X As Axis
    Dim i As Long, m As Long
    Dim ax As Axis

    ' clean up previous attempt
    deleteChart (n)
    If targetLegends > 0 Then
        sc = (ds.max) / targetLegends
    End If
    
    'add the chart
    Set cht = Charts.add
    With cht
        .name = n
        For i = .SeriesCollection.count To 1 Step -1
            .SeriesCollection(i).Delete
        Next i
        Set X = .Axes(xlValue)
        If sc > 0 Then
            X.MajorUnit = sc
        End If
        X.HasMajorGridlines = False
        For i = ds.rows.count To 1 Step -1
            Set dr = ds.rows(i)
            With .SeriesCollection.NewSeries
                .name = dr.cell(1).where
                .XValues = ds.headingRow.where.Offset(, 1).Resize(, dr.columns.count - 1)
                .values = dr.where.Offset(, 1).Resize(, dr.where.columns.count - 1)
            End With
        Next i
        .ChartType = xlt
        

        
        If Not showAxis Then
            For i = .Axes.count To 1 Step -1
                .Axes(i).Delete
            Next i
            .Floor.ClearFormats
        End If
        With .Legend
            ' for some reason legendcount is not ready immediately
            Application.Wait DateAdd("s", 1, Now)
            For i = 1 To .LegendEntries.count
                .LegendEntries(i).LegendKey.Interior.Color = _
                    rampLibraryRGB(colorRampName, 1, .LegendEntries.count, i, brighten)
                
            Next i
        End With
        .HasLegend = showLegend

    End With
    
    Set createSurfaceChart = cht
End Function
Private Function extractArrayItem(a As Variant, n) As Variant
    ' take the nth row of array a
    Dim i As Long, r As Variant
    ReDim r(LBound(a, 1) To UBound(a, 1))
    For i = LBound(r) To UBound(r)
        r(i) = a(i, n)
    Next i
    extractArrayItem = r
    
End Function
Public Function createHotDoughnutChart(ds As cDataSet, n As String, _
                    Optional xlt As Long = xlDoughnut, _
                    Optional granularity As Long = 300, _
                    Optional colorRampName As Variant = "heatmap", _
                    Optional brighten As Double = 1, _
                    Optional createLabelRing As Boolean = True, _
                    Optional labelRingColorRamp As Variant = "lightblue", _
                    Optional explosion As Long = 10, _
                    Optional holeSize As Long = 20, _
                    Optional dataValues As Boolean = False, _
                    Optional rampAppliesToAllSeries = True, _
                    Optional fontOverride As Variant = Empty) As Chart
                    
    Dim cht As Chart, s As Series, dr As cDataRow, dc As cCell
    Dim i As Long, m As Long, co As cDataColumn
    Dim aSlices As Variant, mn As Variant, labelSeries As Variant
    Dim mx As Variant, j As Long, o As Variant, rmn As Variant, rmx As Variant, useRamp As Variant
    Dim aColors As Variant, props As colorProps, k As Long, lab As String, multiRamps As Boolean
    
    ' clean up previous attempt
    deleteChart (n)
    
    'add the chart
    ' the doughnut slices in this case will be equally sized
    ' the heatmap will show the values and fade between mid points
    ReDim aSlices(1 To ds.rows.count * granularity)
    ReDim aColors(1 To ds.rows.count + 2, 2 To ds.columns.count)
    ReDim labelSeries(1 To ds.rows.count)
    
    ' this will determine the min/max values to ramp
    mn = Application.WorksheetFunction.min(ds.where.Offset(, 1).Resize(, ds.columns.count - 1))
    mx = Application.WorksheetFunction.max(ds.where.Offset(, 1).Resize(, ds.columns.count - 1))
    
    ' set all values to same for each category, since we want equal sized slices
    For i = LBound(aSlices) To UBound(aSlices)
        aSlices(i) = 1
    Next i
    
    ' we'll use these as an extra ring for labels
    If createLabelRing Then
        For i = LBound(labelSeries) To UBound(labelSeries)
            labelSeries(i) = 1
        Next i
    End If
    ' the colorrampname could be
    ' - a library entry .. in which case we pass as is
    ' - an array of colors .. in which case can pass as is, ramplibrary knows how to handle them
    ' - an array of entries/colors one for each ring .. so we have to increment for each
    If IsArray(colorRampName) Then multiRamps = Not VarType(colorRampName(LBound(colorRampName))) = vbLong
    
    rmn = mn
    rmx = mx
    For j = LBound(aColors, 2) To UBound(aColors, 2)
        ' this allows for the max/min to apply across all rings or within rings
        If Not rampAppliesToAllSeries Then
            rmn = Application.WorksheetFunction.min(ds.column(j).where)
            rmx = Application.WorksheetFunction.max(ds.column(j).where)
        End If
        
        ' this allows for a different ramp for each ring - ramplapplies to all series should usually be true
        useRamp = colorRampName
        If multiRamps Then useRamp = colorRampName(j - LBound(aColors, 2) + LBound(colorRampName))
        
        For i = 1 To ds.rows.count
            aColors(i + 1, j) = rampLibraryRGB(useRamp, rmn, rmx, ds.value(i, j), brighten)
        Next i
        ' for cycling - add the last color at beginning and first color at end
        aColors(1, j) = aColors(1 + ds.rows.count, j)
        aColors(2 + ds.rows.count, j) = aColors(2, j)
    Next j

    ' create the chart
    Set cht = Charts.add
    With cht
        .ChartType = xlt
        .name = n
        
        ' delete any series added by default
        For i = .SeriesCollection.count To 1 Step -1
            .SeriesCollection(i).Delete
        Next i

        ' add the seriess
        For i = ds.columns.count To 2 Step -1
            Set co = ds.columns(i)
            With .SeriesCollection.NewSeries
                .name = ds.headings(co.column).value
                .values = aSlices
            End With
        Next i
        
        ' add a label series ring
        If createLabelRing Then
            With .SeriesCollection.NewSeries
                .name = ds.headings(1).value
                .values = labelSeries
            End With
        End If

        .HasLegend = False

        ' fiddle with the series colors
        For k = ds.columns.count To 2 Step -1
            Set co = ds.columns(k)
            With .SeriesCollection(ds.headings(co.column).toString)
                .HasDataLabels = True
                For i = 1 To ds.rows.count
                    For j = 0 To granularity - 1
                        ' dealing with this point
                        o = (i - 1) * granularity + j + 1

                        ' note we are already half a granularity along with 1st point
                        props = makeColorProps(colorRamp _
                          (1, (granularity * (ds.rows.count + 1)), o + granularity / 2, _
                            extractArrayItem(aColors, k)))

                        With .Points(o)
                            .Interior.Color = props.rgb
                            lab = ""
                            ' do we need a data label?
                            If dataValues Then
                                If j = 0 Then
                                    lab = ds.value(i, co.column)
                                End If
                            End If
                            ' label first one of these with series name
                            If j = 0 And i = 1 Then
                                If lab <> "" Then
                                    lab = ds.headings(co.column).value & vbCr & lab
                                Else
                                    lab = ds.headings(co.column).value
                                End If
                            End If
                            ' put label or blank it
                            If lab <> "" Then .DataLabel.Font.Color = props.textColor
                            .DataLabel.Text = lab

                        End With
                    Next j
                Next i
            End With
        Next k
        ' fiddle with the labels
        If createLabelRing Then
            With .SeriesCollection(ds.headings(1).value)
                .HasDataLabels = True
                .explosion = explosion
                For Each dr In ds.rows
                    With .Points(dr.row)
                        props = makeColorProps(rampLibraryRGB _
                            (labelRingColorRamp, 1, ds.rows.count, dr.row, brighten))
                        .Interior.Color = props.rgb
                        If IsEmpty(fontOverride) Then
                            .DataLabel.Font.Color = props.textColor
                        Else
                            .DataLabel.Font.Color = fontOverride
                        End If
                        .DataLabel.Text = dr.columns(1).value
                    End With
                Next dr

            End With
        End If
        ' fiddle with holesize
        .ChartGroups(1).DoughnutHoleSize = holeSize
        
    End With
    
    Set createHotDoughnutChart = cht
End Function

Public Function deleteChart(n As String)
    Dim cht As Chart, i As Long

    For i = Charts.count To 1 Step -1
        Set cht = Charts(i)
        If Trim(LCase(cht.name)) = Trim(LCase(n)) Then
            cht.Delete
            Exit For
        End If
    Next i

End Function