Treemap bar charts

D

dayday123

New Member
Joined
Mar 12, 2014
Messages
24
Hi All -

I know with excel 2016 there is the ability to make treemaps but they are very limited. I want to be able to bring in more than one dimension and combine a treemap with a bar chart (like the imagine shown below from tableau). Does anyone know if this is possible to do in excel - i would be willing to potentially pay for an add-in.

Thanks!

tumblr_inline_mggvz1jH7m1ql3h8n.jpg
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
Hi


  • It is possible, see example below.
  • VBA will be necessary to build it.
  • Are you going to do it with Excel 2016? If so, we can use the native tree maps to save some effort.
  • Forum rules forbid monetary transactions, you will get it for free…

jva7mBG.png
 
Upvote 0
o The preliminary version below creates a single tree map bar chart. It was done entirely with VBA.
o Next step will be the multi bar chart.
o Tell me if you need a link to the test workbook.

HXa9oUq.jpg


Code: 
Sub OneBar()
Dim ch As Chart, p As Point, sh As Shape, L, i%, curr As Range, cell As Range, r, blue, _
t As ListObject, n, ra(1 To 2) As Range, sp As Shape, co As ChartObject, uw, sch As Shape
Set t = ActiveSheet.ListObjects(1)                              ' data source is a table
blue = Array(9263620, 11563013, 12619830, 13609332, 14400934)   ' shades of blue
n = Array(1, 2, 3, 4, 5)
Set sch = ActiveSheet.Shapes.AddChart2(216, xlBarClustered)
Set ch = sch.Chart
With ch.SeriesCollection.NewSeries
    .Values = Array(10)
    .XValues = Array(t.Name)
End With
ch.ChartTitle.Delete
ch.Axes(xlValue).MaximumScale = 10
Set p = ch.SeriesCollection(1).Points(1)
Set cell = t.DataBodyRange.Cells(1, 2)
i = 0: L = 0: uw = 0
Set curr = cell
ch.Axes(xlValue).Delete
Do                                                      ' start building from the left
    i = i + 1
    r = curr / Range(Split(t.Range.Address, ":")(1))
   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 = blue(i Mod 5)
   sh.Line.Weight = 0.5
   Set curr = curr.Offset(1)
   L = L + r * p.Width
Loop While r > 0.1 And i < 50
Set cell = curr
Set curr = curr.Offset(, 2)
Set ra(2) = curr.Offset(, 1).Resize(5, 2)
curr.Offset(, 1).Resize(5) = WorksheetFunction.Transpose(n)
curr.Offset(, 2).Resize(5) = WorksheetFunction.Transpose(blue)
i = 0
Do
    i = i + 1                                           ' safety
    curr.Resize(5) = WorksheetFunction.Transpose(n)
    Set curr = curr.Offset(5)
Loop While curr.Row < Range(Split(t.Range.Address, ":")(1)).Row And i < 20
For Each sh In ActiveSheet.Shapes
    If sh.Name Like "Sprk*" Then sh.Delete
Next
Set ra(1) = Range(cell, Range(Split(t.DataBodyRange.Address, ":")(1)))
[d62].Formula = "=treemap(" & ra(1).Address & "," & [e60:j67].Address & ",100,150," & _
ra(1).Offset(, 2).Address & "," & ra(2).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)
sp.CopyPicture                                          ' freeze the small rectangles
ActiveSheet.Paste
Set sp = ActiveSheet.Shapes(Selection.Name)
sp.Copy
Set co = ActiveSheet.ChartObjects.Add(0, 0, sp.Width, sp.Height)
With co.Chart
    .ChartArea.Select
    .Paste
    .Export "c:\pub\tmap.jpg"                           ' your path here
End With
With sh
    .Fill.UserPicture "c:\pub\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
End Sub
 
Upvote 0
This version uses a separate table as data source for each bar:

gQ4fnUR.jpg



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)
    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(, 2).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)
    sh.Name = "MyShape"
    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:\pub\tmap.jpg"                           ' your path here
    End With
    With sh
        .Fill.UserPicture "c:\pub\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
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, xlAscending, , 0
With sht.Sort
    .SetRange r
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub
 
Upvote 0
Worf said:
This version uses a separate table as data source for each bar:

gQ4fnUR.jpg



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)
    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(, 2).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)
    sh.Name = "MyShape"
    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:\pub\tmap.jpg"                           ' your path here
    End With
    With sh
        .Fill.UserPicture "c:\pub\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
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, xlAscending, , 0
With sht.Sort
    .SetRange r
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub
Click to expand...
Hello,

I would like to have a similar chart. Is it possible for you to kindly send the template workbook? My data is based on 7 people and one bar must be assigned to each. Also, for each person, I require 16 fields to show on each bar as a heatmap.


Would you please kindly help me?
I've tried many things and they're not working.

Thanks.
 
Upvote 0
Hello

The code stopped working for me. I will find out what is happening and post back, probably during the weekend.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Trouble creating vertical trendline on clustered bar chart in Excel 2016
Replies
4
Views
715
Jon Peltier
J
S
  • Question
Dynamic stacked bar chart, with variable x-axis and categorical variables
Replies
2
Views
2K
SYKEMAKAVELI
S
E
  • Question
How to add error bars to a stacked bar column chart?
Replies
1
Views
231
edie_needs_help
E
S
  • Question
Big, Multi-Step Macro for Efficiently Cutting Big Pieces Into Small Pieces
Replies
1
Views
182
Solon Aquila
S
M
  • Question
Help with Excel Scroll Bar and %
Replies
2
Views
369
OaklandJim
O

Forum statistics

Threads
1,216,765
Messages
6,132,594
Members
449,737
Latest member
naes

Share this page

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