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