How to implement a Polar Area Chart using VBA

Yoshio Yabusaki — Thu, 29 Aug 2024 07:27:48 +0000

Introduction

This guide explains how to create a Polar Area Chart using VBA.
When you press the button on an Excel sheet, it reads the numbers from the table and displays the following chart.
It works on both Windows and Mac👌

What is the Polar Area Chart?

The Polar area chart is a circular chart made up of multiple sectors that extend radially from the center.
The length (radius) of each sector is proportional to the data value (there are also types where the value is proportional to the area of the sector).
It is useful for visualizing comparative data. For example, you may have seen it in business magazines.
It is said to have originated from the diagram (Nightingale Rose Diagram) designed by Florence Nightingale during the Crimean War.

Source Data

Prepare a table with 16 columns in Excel's Sheet1, range (A1:P2), as shown below.
You can set the column names and numbers freely.
The Polar Area Chart will be drawn based on this data.

Source Code

Prepare two standard modules (Module1, Module2), and place the source code in each as shown below.

Module1

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

Module2

' 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

Calling the Polar Area Chart with a Button

Place a button on the Excel sheet using the [Developer] tab.
Register the macro [PolarAreaChart] to that button.
This will call the procedure of the source code placed in Module1.

When you press the button, it will read the column names and values from the table and display the chart.

The Polar Area Chart is complete🚀
I hope you can customize it to fit the requirements of your project.
Enjoy!!

Reference Site

https://excelbaby.com/questions/nightingale-rose-diagram-excel-template/

DEV Community: Yoshio Yabusaki