はじめに
VBAによるPolar Area Chart (ポーラエリアチャート) の実装方法を解説します。
ボタンを押すと表から数値を読み取り、以下のチャートを表示します。
Windowsはもちろん、Macでも動きます
Polar Area Chartとは
Polar area chartは、円の中心から放射状に伸びる複数のセクターで構成される円形のチャートです。
データの値はセクターの長さ（半径）に比例します（値がセクターの面積に比例するタイプも存在します）。日本語では「鶏頭図」と呼ばれます。
比較データを可視化する場合に役立ちます。ビジネス誌などでご覧になったことがある方もいらっしゃるかもしれません。
フローレンス・ナイチンゲールがクリミア戦争に従軍した際考案したダイアグラム（Nightingale-Rose-Diagram）に起源があるとされています。
元データ
エクセルのSheet1のrange(A1:P2)に以下のようにカラム数16個の表を用意します。
カラム名やそれぞれの数値は自由に設定できます。
このデータを基に、Polar Area Chartが描かれます。
ソースコード
標準モジュールを2つ用意し（Module1, Module2）、それぞれに以下のようにソースコードを配置します。
Module1
Sub PolarAreaChart()
Application.ScreenUpdating = False
' 表が書かれているシートを定義
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Sheets("Sheet1")
' 既にチャートが表示されている場合は削除する
On Error Resume Next
targetSheet.Shapes("MergedGroup").Delete
' 表内の最大値を取得し、それを基に各値の扇形状の高さを計算し、配列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 ' 16カラム分繰り返し
teamValHeight(i) = targetSheet.Cells(2, i).value / maxVal
Next i
' 16Teamの扇形状を回転させながら描く
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, 幅, 高さ
With objShape
.LockAspectRatio = msoTrue ' 扇形状の縦横比を保持
.Fill.ForeColor.RGB = colors(i) ' 扇形状の色を設定
.Line.Visible = msoFalse ' 扇形状の円形部の枠線非表示
.Adjustments.Item(2) = 360 / 16 - 90 ' 扇形状の終了角度を計算
.Rotation = (360 / 16) * (i - 1) ' 扇形状の回転角度を設定
.ScaleHeight teamValHeight(i), msoFalse, msoScaleFromTopLeft ' 扇形状の高さを設定
DiagramShapes(i) = objShape.Name ' 扇形状Nameを配列に保存
End With
Next i
' 16Teamの扇形状を並べグループ化する
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 ' LeftとTopでチャートの位置を調整する
.Top = 80
End With
' チャートの中心点をX軸Y軸で定義する
Dim chartCenterX As Single, chartCenterY As Single
chartCenterX = chartRange.Left + chartRange.Width / 2
chartCenterY = chartRange.Top + chartRange.Height / 2
' 16Teamの名称のテキストボックスを描きグループ化する
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軸、Y軸, ボックスの幅、高さ
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
' 16Teamのデータラベルのテキストボックスを描きグループ化する
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軸、Y軸, ボックスの幅、高さ
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
' 円を4つ描き（外側から内側へ）グループ化する
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
' 放射線を8本描きグループ化する
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
' 目盛りのテキストボックスを4つ描きグループ化する
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
' 完成したチャートをコピペできるよう、全てのグループを一つのグループにマージする
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
' 各Teamの扇形状の色
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
' 各Team名の位置
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
' 各Teamのデータラベルの位置
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
' 目盛りの位置
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
Polar Area Chartをボタンで呼び出す
[開発]タブでエクセル上にボタンを設置します。
そのボタンにマクロ[PolarAreaChart]を登録します。
これにより、Module1に配置したプロシージャ「PolarAreaChart」が呼び出される、というわけです。↓
Sub PolarAreaChart()
ボタンを押すと表からカラム名と数値が読み取られ、チャートが表示されます。
Polar Area Chart 完成です
皆様のプロジェクトで求められる仕様にカスタマイズして使って頂ければうれしいです。
参考サイト