Combination Chart: Bars and TreeMap with VBA

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