How to implement a Polar Area Chart using VBA

Sub PolarAreaChart()
    Application.ScreenUpdating = False


' Define the sheet containing the table.
    Dim targetSheet As Worksheet
    Set targetSheet = ThisWorkbook.Sheets("Sheet1")


' Delete any existing chart if it is already displayed.
    On Error Resume Next
    targetSheet.Shapes("MergedGroup").Delete


' Get the maximum value from the table, calculate the height of each PizzaPie based on it, and write it into the array teamValHeight.
    Dim maxVal As Long
    With Application.WorksheetFunction
        maxVal = .Max(targetSheet.Range("A2:P2"))
    End With

    Dim teamValHeight(1 To 16) As Double
    Dim i As Long
    For i = 1 To 16  ' Repeat for 16 columns.
        teamValHeight(i) = targetSheet.Cells(2, i).value / maxVal
    Next i


' Draw the 16 Teams' PizzaPies while rotating them.
    Dim colors As Variant
    colors = TeamColors()

    Dim objShape As Object
    Dim DiagramShapes(1 To 16) As String
    For i = 1 To 16
        Set objShape = targetSheet.Shapes.AddShape(msoShapeArc, 410, 200, 175, 175)   ' Left, top, width, height
        With objShape
            .LockAspectRatio = msoTrue  ' Maintain the aspect ratio of the PizzaPies
            .Fill.ForeColor.RGB = colors(i)  ' Set the colors of the PizzaPies
            .Line.Visible = msoFalse  ' Hide the border of the circular part of the PizzaPies
            .Adjustments.Item(2) = 360 / 16 - 90 ' Calculate the end angle of the PizzaPies
            .Rotation = (360 / 16) * (i - 1) ' Set the rotation angle of the PizzaPies
            .ScaleHeight teamValHeight(i), msoFalse, msoScaleFromTopLeft  ' Set the height of the PizzaPies
            DiagramShapes(i) = objShape.Name  ' Save the name of the PizzaPies in the array "DiagramShapes"
        End With
    Next i


' Adjust the position of the 16 PizzaPies and group them
    Dim chartRange As Object
    Set chartRange = targetSheet.Shapes.Range(DiagramShapes)
    With chartRange
        .Align msoAlignLefts, msoFalse
        .Align msoAlignTops, msoFalse
        .Align msoAlignCenters, msoFalse
        .Align msoAlignMiddles, msoFalse
        .Group
        .Name = "polarAreaGroup"
        .Left = 220  ' Position the chart with Left and Top
        .Top = 80
    End With


' Define the center point of the chart with the X and Y axes
    Dim chartCenterX As Single, chartCenterY As Single
    chartCenterX = chartRange.Left + chartRange.Width / 2
    chartCenterY = chartRange.Top + chartRange.Height / 2


' Draw and group the text boxes for the 16 Teams' names
    Dim teamName() As Variant
    Dim txtBoxTeam As Object
    Dim txtBoxesTeams(1 To 16) As String
    teamName = TeamNamePositions(chartCenterX, chartCenterY)
    For i = 1 To 16
        Set txtBoxTeam = targetSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
            teamName(i)(0), teamName(i)(1), 65, 20)  ' X-axis, Y-axis, width, height
        With txtBoxTeam.TextFrame.Characters
            .Text = targetSheet.Cells(1, i).value
            .Font.Size = 13
            .Font.Bold = False
            .Font.color = RGB(0, 51, 153)
        End With
        txtBoxTeam.TextFrame.HorizontalAlignment = xlCenter
        txtBoxTeam.Line.Visible = msoFalse
        txtBoxTeam.Fill.Visible = msoFalse
        txtBoxesTeams(i) = txtBoxTeam.Name
    Next i

    Dim teamNameRange As Object
    Set teamNameRange = targetSheet.Shapes.Range(txtBoxesTeams)
    With teamNameRange
        .Group
        .Name = "teamNameGroup"
    End With


' Draw and group the text boxes for the 16 Teams' data labels
    Dim targetSum As Long
    Dim labelPosition() As Variant
    targetSum = Application.WorksheetFunction.Sum(targetSheet.Range("A2:P2"))
    labelPosition = DataLabelPositions(chartCenterX, chartCenterY)

    Dim targetRange As Variant
    Dim targetVal(1 To 16) As Long
    Dim targetPercent(1 To 16) As Double
    targetRange = targetSheet.Range("A2:P2").value
    For i = 1 To 16
        targetVal(i) = (targetRange(1, i))
        targetPercent(i) = targetSheet.Cells(2, i).value / targetSum
    Next i

    Dim txtBoxLabel As Object
    Dim txtBoxesLabels(1 To 16) As String
    For i = 1 To 16
        Set txtBoxLabel = targetSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
            labelPosition(i)(0), labelPosition(i)(1), 100, 20)  ' X-axis, Y-axis, width, height
        With txtBoxLabel.TextFrame.Characters
            .Text = targetVal(i) & " (" & Format(targetPercent(i) * 100, "0.0") & "%)"
            .Font.Size = 11
            .Font.color = RGB(89, 89, 89)
        End With
        txtBoxLabel.TextFrame.HorizontalAlignment = xlCenter
        txtBoxLabel.Line.Visible = msoFalse
        txtBoxLabel.Fill.Visible = msoFalse
        txtBoxesLabels(i) = txtBoxLabel.Name
    Next i

    Dim dataLabelRange As Object
    Set dataLabelRange = targetSheet.Shapes.Range(txtBoxesLabels)
    With dataLabelRange
        .Group
        .Name = "dataLabelGroup"
    End With


' Draw four circles (from outer to inner) and group them
    Dim chartCircle As Shape
    For i = 0 To 3
        Set chartCircle = targetSheet.Shapes.AddShape(msoShapeOval, _
            chartCenterX - 175 + (43.75 * i), chartCenterY - 175 + (43.75 * i), 350 - (87.5 * i), 350 - (87.5 * i))
        With chartCircle
            .Fill.Visible = msoFalse
            .Line.Weight = 0.3
            .Line.ForeColor.RGB = RGB(191, 191, 191)
            .Name = "chartCircle_" & i + 1
        End With
    Next i


' Draw and group eight radial lines
    Dim chartLine As Shape
    Dim chartLines(1 To 8) As String
    For i = 1 To 8
        Set chartLine = targetSheet.Shapes.AddConnector( _
            msoConnectorStraight, chartCenterX - 175, chartCenterY, chartCenterX + 175, chartCenterY)
        With chartLine
            .Line.Weight = 0.3
            .Line.ForeColor.RGB = RGB(191, 191, 191)
            .Rotation = (360 / 16) * i
            chartLines(i) = chartLine.Name
        End With
    Next i

    Dim chartLinesRange As Object
    Set chartLinesRange = targetSheet.Shapes.Range(chartLines)
    With chartLinesRange
        .Group
        .Name = "chartLineGroup"
    End With


' Draw and group four text boxes for the scale
    Dim scalePosition() As Variant
    scalePosition = CalculateScalePositions(chartCenterX, chartCenterY)

    Dim txtBoxScale As Object
    Dim txtBoxesScales(1 To 4)  As String
    For i = 1 To 4
        Set txtBoxScale = targetSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
            scalePosition(i)(0), scalePosition(i)(1), 35, 10)
        With txtBoxScale.TextFrame.Characters
            .Text = maxVal - (maxVal / 4 * (i - 1))
            .Font.Size = 8
            .Font.color = RGB(89, 89, 89)
        End With
        txtBoxScale.TextFrame.HorizontalAlignment = xlCenter
        txtBoxScale.TextFrame.VerticalAlignment = xlVAlignCenter
        txtBoxScale.Fill.Visible = msoFalse
        txtBoxScale.Line.Visible = msoFalse
        txtBoxesScales(i) = txtBoxScale.Name
    Next i

    Dim scaleRange As Object
    Set scaleRange = targetSheet.Shapes.Range(txtBoxesScales)
    With scaleRange
        .Group
        .Name = "scaleGroup"
    End With


' Merge all groups into one group so that the finished chart can be copied and pasted
    Dim MergedGroup As Object
    Set MergedGroup = targetSheet.Shapes.Range( _
        Array( _
            "polarAreaGroup", _
            "teamNameGroup", _
            "dataLabelGroup", _
            "chartCircle_1", _
            "chartCircle_2", _
            "chartCircle_3", _
            "chartCircle_4", _
            "chartLineGroup", _
            "scaleGroup" _
        ) _
    )
    With MergedGroup
        .Group
        .Name = "MergedGroup"
    End With


    Application.ScreenUpdating = True
End Sub

' Color of each Team's PizzaPie
Public Function TeamColors() As Variant
    Dim color(1 To 16) As String
    color(1) = RGB(255, 227, 133)  ' Team1
    color(2) = RGB(255, 177, 139)  ' Team2
    color(3) = RGB(148, 255, 161)  ' Team3
    color(4) = RGB(148, 206, 255)  ' Team4
    color(5) = RGB(199, 255, 142)  ' Team5
    color(6) = RGB(147, 255, 218)  ' Team6
    color(7) = RGB(95, 197, 250)  ' Team7
    color(8) = RGB(236, 147, 255)  ' Team8
    color(9) = RGB(153, 245, 255)  ' Team9
    color(10) = RGB(242, 198, 53)  ' Team10
    color(11) = RGB(194, 150, 255)  ' Team11
    color(12) = RGB(255, 203, 139)  ' Team12
    color(13) = RGB(47, 224, 160)  ' Team13
    color(14) = RGB(255, 141, 191)  ' Team14
    color(15) = RGB(149, 163, 255)  ' Team15
    color(16) = RGB(255, 248, 134)  ' Team16
    TeamColors = color
End Function


' Position of each Team's name
Public Function TeamNamePositions(ByVal chartCenterX As Single, ByVal chartCenterY As Single) As Variant
    Dim teamNamePosition(1 To 16) As Variant
    teamNamePosition(1) = Array(chartCenterX + 6, chartCenterY - 200)  ' Team1
    teamNamePosition(2) = Array(chartCenterX + 80, chartCenterY - 175)  ' Team2
    teamNamePosition(3) = Array(chartCenterX + 138, chartCenterY - 120)  ' Team3
    teamNamePosition(4) = Array(chartCenterX + 167, chartCenterY - 52)   ' Team4
    teamNamePosition(5) = Array(chartCenterX + 167, chartCenterY + 25)   ' Team5
    teamNamePosition(6) = Array(chartCenterX + 138, chartCenterY + 94)   ' Team6
    teamNamePosition(7) = Array(chartCenterX + 90, chartCenterY + 150)   ' Team7
    teamNamePosition(8) = Array(chartCenterX + 6, chartCenterY + 177)   ' Team8
    teamNamePosition(9) = Array(chartCenterX - 69, chartCenterY + 177)   ' Team9
    teamNamePosition(10) = Array(chartCenterX - 145, chartCenterY + 150) ' Team10
    teamNamePosition(11) = Array(chartCenterX - 205, chartCenterY + 94)  ' Team11
    teamNamePosition(12) = Array(chartCenterX - 235, chartCenterY + 25)  ' Team12
    teamNamePosition(13) = Array(chartCenterX - 235, chartCenterY - 50)  ' Team13
    teamNamePosition(14) = Array(chartCenterX - 205, chartCenterY - 120) ' Team14
    teamNamePosition(15) = Array(chartCenterX - 145, chartCenterY - 175) ' Team15
    teamNamePosition(16) = Array(chartCenterX - 69, chartCenterY - 200)  ' Team16
    TeamNamePositions = teamNamePosition
End Function


' Position of each Team's data label
Public Function DataLabelPositions(ByVal chartCenterX As Single, ByVal chartCenterY As Single) As Variant
    Dim labelPosition(1 To 16) As Variant
    labelPosition(1) = Array(chartCenterX - 13, chartCenterY - 215)   ' Team1
    labelPosition(2) = Array(chartCenterX + 55, chartCenterY - 190)   ' Team2
    labelPosition(3) = Array(chartCenterX + 113, chartCenterY - 135)   ' Team3
    labelPosition(4) = Array(chartCenterX + 152, chartCenterY - 67)   ' Team4
    labelPosition(5) = Array(chartCenterX + 152, chartCenterY + 42)   ' Team5
    labelPosition(6) = Array(chartCenterX + 118, chartCenterY + 111) ' Team6
    labelPosition(7) = Array(chartCenterX + 65, chartCenterY + 167)  ' Team7
    labelPosition(8) = Array(chartCenterX - 13, chartCenterY + 194)  ' Team8
    labelPosition(9) = Array(chartCenterX - 88, chartCenterY + 194)  ' Team9
    labelPosition(10) = Array(chartCenterX - 160, chartCenterY + 167) ' Team10
    labelPosition(11) = Array(chartCenterX - 218, chartCenterY + 111) ' Team11
    labelPosition(12) = Array(chartCenterX - 250, chartCenterY + 42)  ' Team12
    labelPosition(13) = Array(chartCenterX - 250, chartCenterY - 65)  ' Team13
    labelPosition(14) = Array(chartCenterX - 218, chartCenterY - 135)  ' Team14
    labelPosition(15) = Array(chartCenterX - 160, chartCenterY - 190)  ' Team15
    labelPosition(16) = Array(chartCenterX - 88, chartCenterY - 215)   ' Team16
    DataLabelPositions = labelPosition
End Function


' Position of the scale
Public Function CalculateScalePositions(ByVal chartCenterX As Single, ByVal chartCenterY As Single) As Variant
    Dim scalePosition(1 To 4) As Variant
    scalePosition(1) = Array(chartCenterX + 156.8, chartCenterY)    ' First
    scalePosition(2) = Array(chartCenterX + 113.05, chartCenterY) ' Second
    scalePosition(3) = Array(chartCenterX + 69.3, chartCenterY) ' Third
    scalePosition(4) = Array(chartCenterX + 25.55, chartCenterY)  ' Fourth
    CalculateScalePositions = scalePosition
End Function