• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Worf

Combination Chart: Bars and TreeMap with VBA

Excel Version
  1. 2016
Excel presents a wide variety of charts, but not a hybrid of bars and tree maps. It is not necessary to write code for custom tree maps because a guy named Fabrice Rimlinger already did that when creating the add-in mentioned below.

His source code is not protected so you can look at it after installing the add-in. Here are the main features of my code:

  • Uses tables as a data source, one of them is shown beneath. The addresses used for this example were: B70:C81, B83:C94, B96:C111, B113:C130, B132:C143 and B145:C180
  • Creates the bars from ordinary shapes and tree maps produced by the add-in.
  • Defines colours as arrays of integers.
  • Writes intermediary pictures to disk.

bartm.png


ranges.xlsm
BC
132countryamount
133c133876
134c226058
135c320045
136c415419
137c511861
138c69124
139c77018
140c85399
141c94153
142c103194
143Total136148
Sheet3
Cell Formulas
RangeFormula
C134:C142C134=C133/1.3
C143C143=SUBTOTAL(109,[amount])


VBA Code:
Sub Bars()
Dim ch As Chart, p As Point, sh As Shape, L, i%, curr As Range, cell As Range, j%, r, _
t As ListObject, n, ra(1 To 3) As Range, sp As Shape, co As ChartObject, uw, sch As Shape, colors(1 To 6)
colors(1) = Array(9263620, 11563013, 12619830, 13609332, 14400934)   ' shades of blue
colors(2) = Array(10670333, 7057149, 3968509, 1272305, 84185)      ' orange
colors(3) = Array(10744025, 9362861, 7980664, 6138689, 4424739)     ' green
colors(4) = Array(12633596, 11902970, 10578167, 9909469, 8257966)     ' red
colors(5) = Array(14466492, 13146782, 12221823, 10703210, 9381716) ' purple
colors(6) = Array(539519, 415923, 1344223, 6535421, 11985150)       ' brown
For Each co In ActiveSheet.ChartObjects
    If co.TopLeftCell.Address = "$A$1" Then co.Delete
Next
For Each sh In ActiveSheet.Shapes
    If sh.Name Like "Re*" Or sh.Name Like "Pic*" Then sh.Delete
Next
n = Array(1, 2, 3, 4, 5)
Set sch = ActiveSheet.Shapes.AddChart2(216, xlBarClustered)
Set ch = sch.Chart
ch.Parent.Width = [f20:n20].Width
ch.Parent.Height = [f100:f120].Height
Set curr = [e70]        ' row where tables start
For i = 1 To 20
    curr.Resize(5) = WorksheetFunction.Transpose(n)
    Set curr = curr.Offset(5)
Next
For i = 1 To ActiveSheet.ListObjects.Count                                  ' create the bars
    Set t = ActiveSheet.ListObjects(i)
    t.DataBodyRange.Cells(1, 1).Offset(, 5).Resize(5) = WorksheetFunction.Transpose(colors(i))
    With ch.SeriesCollection.NewSeries
        .Values = Array(10 * t.TotalsRowRange.Cells(1, 2) / WorksheetFunction.Max([c:c]))
        .Name = t.Name
        .ApplyDataLabels
        .DataLabels.ShowSeriesName = 1
        .DataLabels.ShowValue = 0
        .XValues = Array(t.Name)
    End With
Next
ch.ChartGroups(1).Overlap = -15
ch.Axes(xlCategory).Delete
ch.Axes(xlValue).Delete
For i = 1 To ActiveSheet.ListObjects.Count                                  ' loop the tables
    Set t = ActiveSheet.ListObjects(i)
    Set curr = t.DataBodyRange.Cells(1, 2)
    Set p = ch.SeriesCollection(t.Name).Points(1)
    p.Format.Fill.Visible = msoFalse
    p.Format.Line.Visible = msoFalse
    j = 0: L = 0: uw = 0
    Do While curr / WorksheetFunction.Max([c:c]) > 0.1 And j < 50           ' big rectangles
        j = j + 1
        r = curr / t.TotalsRowRange.Cells(1, 2)
        Set sh = ch.Shapes.AddShape(1, ch.PlotArea.InsideLeft + L, p.Top, r * p.Width, p.Height)
        uw = uw + r * p.Width
        sh.Fill.ForeColor.RGB = colors(i)(j Mod 5)
        sh.Line.Weight = 0.5
        Set curr = curr.Offset(1)
        L = L + r * p.Width
    Loop
    n(0) = curr.Offset(, 2) + 1
    If n(0) = 6 Then n(0) = 1
    For j = 1 To 4                      ' adjacent colors must be different
        n(j) = n(j - 1) + 1
        If n(j) = 6 Then n(j) = 1
    Next
    t.DataBodyRange.Cells(1, 1).Offset(, 4).Resize(5) = WorksheetFunction.Transpose(n)
    Set ra(1) = Range(curr, t.TotalsRowRange.Cells(1, 2).Offset(-1))
    Set ra(2) = t.DataBodyRange.Cells(1, 1).Offset(, 6).Resize(5, 7)
    Set ra(3) = t.DataBodyRange.Cells(1, 1).Offset(, 4).Resize(5, 2)
    Sorter ra(3)
    t.DataBodyRange.Cells(1, 1).Offset(, 20).Formula = "=treemap(" & ra(1).Address & "," & ra(2).Address & ",100,150," & _
    ra(1).Offset(, 2).Address & "," & ra(3).Address & ")"
    For Each sh In ActiveSheet.Shapes
        If sh.Name Like "Sprk*" Then
            Set sp = sh
            Exit For
        End If
    Next
    Set sh = ch.Shapes.AddShape(1, 20, 20, sp.Width / 2, sp.Height / 2)
    Select Case L = 0
        Case True: sh.Name = "MyShapeL"
        Case False: sh.Name = "MyShape"
    End Select
    sp.CopyPicture                                          ' freeze the small rectangles
    Set co = ActiveSheet.ChartObjects.Add(0, 0, sp.Width, sp.Height)
    With co.Chart
        .ChartArea.Select
        .Paste
        .Export "c:\test\tmap.jpg"                           ' your path here
    End With
    With sh
        .Fill.UserPicture "c:\test\tmap.jpg"                 ' your path here
        .Line.Weight = 0.5
        .Width = p.Width - uw
        .Top = p.Top
        .Height = p.Height
        .Left = p.Width - sh.Width + ch.PlotArea.InsideLeft
    End With
    sp.Delete
Next
For i = 1 To ch.Shapes.Count
    If ch.Shapes(i).Name = "MyShapeL" Then ch.Shapes(i).Line.ForeColor.RGB = RGB(250, 250, 250)
Next
End Sub

Sub Sorter(r As Range)
Dim sht As Worksheet
Set sht = ActiveSheet
sht.Sort.SortFields.Clear
sht.Sort.SortFields.Add r.Cells(1, 1), xlSortOnValues, 1, , 0
With sht.Sort
    .SetRange r
    .Header = xlNo
    .MatchCase = False
    .Orientation = 1
    .SortMethod = xlPinYin
    .Apply
End With
End Sub
Author
Worf
Views
1,526
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Worf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top