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.
Reference Site
https://excelbaby.com/questions/nightingale-rose-diagram-excel-template/
Top comments (0)