面積グラフとは
面積グラフは、各項目の割合を縦横両方向に100%積み上げて面積で示すグラフです。例えば、以下のようなデータがあるとします。
このデータを基に作成される面積グラフは次のようになります。
面積グラフは、データの割合を視覚的に分かりやすく示すのに非常に便利です。
厚労省が策定しているデータヘルス計画の中で、健康分布図としても使われていたりします。
面積グラフのほかに、マリメッコチャート、マリメッコグラフ、メッコチャート、面積図などと呼ばれることもあるようです。
この記事の要点
面積グラフをVBAで次のように指定して作ります。
'SetMensekizu データ範囲, グラフ作成範囲
SetMensekizu Range("B2:E4"), Range("B7:E20")
データ範囲には、この記事の最初に紹介したような項目名のあるデータのセル範囲を指定します。
なぜVBAで作るのか
エクセルの標準機能にあるツリーマップでも、各項目を面積で表すことができますが、1項目に対する面積を表すためのもので、面積グラフのように2項目を表すことを目的とはしていません。
また、次のリンク先のように、エクセルの標準機能でも面積グラフを一応作ることができるようですが、グラフを作成するための作業用の表を作る必要があり、ちょっと面倒です。
BIZPERA - 【5分でわかる】マリメッコグラフはExcelで作れる
think-cell - メッコチャートとは?使い方やExcelでの作成方法を解説
この作業用の表を作るのが面倒でないとか、一度作ればいい場合は、上記リンクの方法をお勧めしますが、そんな表を作るのが面倒過ぎるという方は、この記事の方法をお試しください。
VBAコード
以下のコードを標準モジュールに貼り付け、Main_MakeMensekizu()内のセル範囲を適宜変更してください。データ範囲とグラフの貼り付け範囲を指定します。Range("B2:E4")
のような書き方もOKです。
Option Explicit
Sub Main_MakeMensekizu()
SetMensekizu ThisWorkbook.Sheets("data").Cells(2, 3).CurrentRegion, ThisWorkbook.Sheets("data").Cells(7, 2).Resize(13, 4)
End Sub
Function SetMensekizu(rgData As Range, rgPaste As Range, Optional strFont As String = "メイリオ", Optional iMargin As Integer = 4, _
Optional strSavePath As String, Optional dSize As Double = 6, Optional blScale As Boolean = True, _
Optional blUsageGuide As Boolean = True, Optional blColumnHeading As Boolean = True)
'面積図を作成し、指定したセル範囲に貼り付ける
DeleteShapesInRange rgPaste '既存のシェイプオブジェクトを削除
If rgData Is Nothing Then Exit Function
Dim shape1 As Object
Set shape1 = makeMensekizu(rgData.Cells.Value, rgPaste, strFont, iMargin, dSize, blScale, blUsageGuide, blColumnHeading)
If strSavePath <> "" Then SaveShapeAsPngFile shape1, strSavePath
End Function
Function makeMensekizu(mtrxData As Variant, rgPaste As Range, Optional strFontName As String = "Arial", Optional iMargin As Integer = 4, Optional dSize As Double = 6, Optional blScale As Boolean = True, _
Optional blUsageGuide As Boolean = True, Optional blColumnHeading As Boolean = True) As Object
'面積図や面チャートと呼ばれるグラフを作成し、指定セル範囲に貼り付け、オブジェクトとして返す
Application.ScreenUpdating = False
Dim i As Integer, j As Integer
Dim M As Integer
Dim t As Double
Dim shbar As Worksheet, sh As Worksheet
Const conRate = 3
'作表用シートの準備
Dim wsWork As Worksheet
If SheetExistance("mensekizu_work", ThisWorkbook) Then
Set wsWork = ThisWorkbook.Sheets("mensekizu_work")
Else
Set wsWork = ThisWorkbook.Sheets.Add
End If
ActivateCell wsWork.Cells(1, 1)
wsWork.Cells.Delete
dSize = dSize / rgPaste.Width * 180
wsWork.Cells.Interior.Color = RGB(255, 255, 255)
wsWork.Cells.ColumnWidth = 1.28 * conRate / dSize
wsWork.Cells.RowHeight = 16 * conRate / dSize * rgPaste.Height / rgPaste.Width
wsWork.Rows("103:103").RowHeight = 15 * conRate
wsWork.Rows("103:103").VerticalAlignment = xlTop
wsWork.Cells(103, 1).Resize(2, 100).HorizontalAlignment = xlCenterAcrossSelection
wsWork.Cells.Font.Size = 10 * conRate
wsWork.Columns(101).ColumnWidth = 1 * conRate
'グラフ描画のためのデータ取得
'データ補正 数字以外と負数を0にする
Dim iC As Long, iR As Long
For iC = 2 To UBound(mtrxData, 2)
For iR = 2 To UBound(mtrxData, 1)
If Not IsNumeric(mtrxData(iR, iC)) Then mtrxData(iR, iC) = 0
If mtrxData(iR, iC) < 0 Then mtrxData(iR, iC) = 0
Next
Next
'各列の合計を取得
Dim lSumTotal As Long, lSumCol() As Variant
ReDim lSumCol(UBound(mtrxData, 2))
For iC = 2 To UBound(mtrxData, 2)
For iR = 2 To UBound(mtrxData, 1)
lSumTotal = lSumTotal + mtrxData(iR, iC)
lSumCol(iC) = lSumCol(iC) + mtrxData(iR, iC)
Next
Next
'各行列の割合を計算
Dim lPercentCol() As Variant, lPercentRow() As Variant
ReDim lPercentCol(UBound(mtrxData, 2)), lPercentRow(UBound(mtrxData, 1), UBound(mtrxData, 2))
For iC = 2 To UBound(mtrxData, 2)
lPercentCol(iC) = Int(lSumCol(iC) / lSumTotal * 100 + 0.5)
For iR = 2 To UBound(mtrxData, 1)
lPercentRow(iR, iC) = Int(mtrxData(iR, iC) / lSumCol(iC) * 100 + 0.5)
Next
Next
'描画
Dim rg1 As Range, lRow As Long, lCol As Long
lRow = 1
lCol = 1
For iC = 2 To UBound(mtrxData, 2)
If lPercentCol(iC) > 0 Then
If iC = UBound(mtrxData, 2) Then lPercentCol(iC) = 101 - lCol
For iR = 2 To UBound(mtrxData, 1)
If lPercentRow(iR, iC) > 0 Then
'合計が100になるように補正
If iR = UBound(mtrxData, 1) Then lPercentRow(iR, iC) = 101 - lRow
Set rg1 = wsWork.Cells(lRow, lCol).Resize(lPercentRow(iR, iC), lPercentCol(iC))
'色
rg1.Interior.ThemeColor = ((iR - 2) Mod 6) + 5
rg1.Interior.TintAndShade = Int((iR - 2) / 6) * 0.2
makeBorders rg1 '罫線
makeLabel rg1, CStr(mtrxData(iR, iC)), CDbl(conRate) 'ラベル
lRow = lRow + lPercentRow(iR, iC)
End If
Next
wsWork.Cells(103, lCol).Value = mtrxData(1, iC)
lRow = 1
lCol = lCol + lPercentCol(iC)
End If
Next
wsWork.Rows(103).Cut
wsWork.Rows(1).Insert
If Not blColumnHeading Then
wsWork.Rows(1).RowHeight = 0
End If
'目盛
wsWork.Columns(1).Resize(, 2).Insert
If blScale Then
wsWork.Columns(1).ColumnWidth = 2.3 * conRate
' wsWork.Rows(1).RowHeight = 4
wsWork.Rows(103).RowHeight = 11 * conRate
For i = 0 To 100 Step 20
'縦
makeLabel wsWork.Cells(i + 2, 1), CStr(100 - i), conRate * 0.6
wsWork.Cells(i + 2, 2).Borders(xlEdgeTop).LineStyle = xlContinuous
'横
makeLabel wsWork.Cells(103, i + 3), CStr(i), conRate * 0.6
wsWork.Cells(102, i + 3).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next
End If
'凡例
Dim rgH As Range, str1 As String
Set rgH = wsWork.Cells(105, 3)
If blUsageGuide Then
rgH.EntireRow.RowHeight = 11 * conRate
For i = 2 To UBound(mtrxData, 1)
rgH.Value = rgH.Value & " ■" & mtrxData(i, 1)
Next
For i = 2 To UBound(mtrxData, 1)
str1 = str1 & " ■"
rgH.Characters(Len(str1), 1).Font.ThemeColor = ((i - 2) Mod 6) + 5
rgH.Characters(Len(str1), 1).Font.TintAndShade = Int((iR - 2) / 6) * 0.2
str1 = str1 & mtrxData(i, 1)
Next
Else
rgH.EntireRow.RowHeight = 0
End If
'ワーク用のシートから貼付セル範囲へコピー & ペースト
Dim rgPrintOut As Range
Set rgPrintOut = wsWork.Cells(1, 1).Resize(105, 104)
DoEvents
Application.Wait Now() + 1 / 24 / 60 / 60
rgPrintOut.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ActivateCell rgPaste
DoEvents
rgPaste.PasteSpecial
Dim shape1 As Object
Set shape1 = Selection
'サイズ調整
With shape1
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.PictureFormat.Crop.PictureHeight = .Height + .Height - rgPrintOut.Height
.ShapeRange.PictureFormat.Crop.PictureOffsetY = (.Height - rgPrintOut.Height) / 2
.ShapeRange.PictureFormat.Crop.PictureWidth = .Width + .Width - rgPrintOut.Width
.ShapeRange.PictureFormat.Crop.PictureOffsetX = (.Width - rgPrintOut.Width) / 2
.Height = rgPaste.Height - iMargin
.Width = rgPaste.Width - iMargin
.Left = rgPaste.Left + iMargin / 2
.Top = rgPaste.Top + iMargin / 2
End With
'ワーク用シートの削除 もとからmensekizu_workシートがあればそのまま残す
If wsWork.Name <> "mensekizu_work" Then
Application.DisplayAlerts = False
wsWork.Delete
Application.DisplayAlerts = True
End If
Set makeMensekizu = shape1
End Function
Sub makeBorders(rg1 As Range)
'外枠の罫線を作成
rg1.Borders(xlEdgeBottom).LineStyle = xlContinuous
rg1.Borders(xlEdgeLeft).LineStyle = xlContinuous
rg1.Borders(xlEdgeRight).LineStyle = xlContinuous
rg1.Borders(xlEdgeTop).LineStyle = xlContinuous
End Sub
Function makeLabel(rg1 As Range, text1 As String, dRate As Double) As Shape
Set makeLabel = rg1.Parent.Shapes.AddTextbox(msoTextOrientationHorizontal, rg1.Left, rg1.Top, rg1.Width, rg1.Height)
makeLabel.Fill.Visible = msoFalse
makeLabel.Line.Visible = msoFalse
makeLabel.TextFrame.HorizontalAlignment = xlHAlignCenter
makeLabel.TextFrame.VerticalAlignment = xlVAlignCenter
makeLabel.TextFrame.AutoSize = True
makeLabel.TextFrame.Characters.Font.Size = 11 * dRate
makeLabel.TextFrame.Characters.Text = text1
End Function
Sub DeleteShapesInRange(rg1 As Range)
'セル範囲に含まれるShapeオブジェクトを削除する(画像type=13のみ削除)
Dim shape1 As Shape
For Each shape1 In rg1.Parent.Shapes
If shape1.Type = 13 Then
If Not Intersect(rg1, _
shape1.TopLeftCell.Resize(shape1.BottomRightCell.Row - shape1.TopLeftCell.Row + 1, _
shape1.BottomRightCell.Column - shape1.TopLeftCell.Column + 1)) Is Nothing Then
shape1.Delete
End If
End If
Next
End Sub
Function SaveShapeAsPngFile(shape1 As Object, strSavePath As String)
'Save Shape1 as strSavePath (PNG format)
'受け取ったShape1をPNG画像としてstrSavePathに保存する
Dim ws1 As Worksheet
shape1.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set ws1 = getWorksheet("shape_work", Workbooks.Add)
ws1.ChartObjects.Add 0, 0, shape1.Width, shape1.Height
Dim i As Long
i = 0
With ws1.ChartObjects(ws1.ChartObjects.Count).Chart
'貼付実行可能になるまで時間差があるため貼り付けるまでループさせる
Do
Application.Wait Now() + 1 / 24 / 60 / 60 * 0.1
.Paste
DoEvents
i = i + 1
Loop While .Shapes.Count < 1 And i < 100
.Export strSavePath, filtername:="PNG"
.Parent.Delete
End With
ws1.Parent.Close False
End Function
Function SheetExistance(sheetName As String, wb As Workbook) As Boolean
'シートの存在確認
Dim sh As Worksheet
On Error Resume Next
Set sh = wb.Sheets(sheetName)
On Error GoTo 0
SheetExistance = Not sh Is Nothing
End Function
Sub ActivateCell(rg1 As Range)
ActivateCell1 rg1.Parent, rg1.Address
End Sub
Sub ActivateCell1(ws1 As Worksheet, strRg As String)
'たんにセルをActivateして表示する
ws1.Parent.Activate
ws1.Activate
Dim rg1 As Range
Set rg1 = ws1.Range(strRg)
If rg1 Is Nothing Then Exit Sub
rg1.Select
ActiveWindow.ScrollRow = Application.WorksheetFunction.Max(1, Int(rg1.Row - ActiveWindow.VisibleRange.Rows.Count / 2))
ActiveWindow.ScrollColumn = Application.WorksheetFunction.Max(1, Int(rg1.Column - ActiveWindow.VisibleRange.Columns.Count / 2))
If rg1.Row > ActiveWindow.VisibleRange.Row + ActiveWindow.VisibleRange.Rows.Count - 2 Then ActiveWindow.ScrollRow = rg1.Row
If rg1.Column > ActiveWindow.VisibleRange.Column + ActiveWindow.VisibleRange.Columns.Count - 2 Then ActiveWindow.ScrollColumn = rg1.Column
End Sub
Function getWorksheet(strSheetName As String, wb1 As Workbook) As Worksheet
'Return exist worksheet or new worksheet that name is strSheetName in Wb1
'Wb1にstrSheetNameのシート名があればそのシート、なければ新しいシートにシート名を付けて返す
If SheetExistance(strSheetName, wb1) Then
Set getWorksheet = wb1.Sheets(strSheetName)
Exit Function
End If
wb1.Sheets.Add After:=wb1.Sheets(wb1.Sheets.Count)
Set getWorksheet = wb1.Sheets(wb1.Sheets.Count)
getWorksheet.Name = strSheetName
End Function
SetMensekizu の各オプションについて
SetMensekizu関数にはいくつかのオプション引数があります。これらの引数を使用することで、グラフの見た目や挙動をカスタマイズすることができます。
- strFont (Optional, Default: "メイリオ") : グラフ内のテキストのフォント名を指定します。
- iMargin (Optional, Default: 4) : グラフのマージン(余白)をピクセル単位で指定します。
- strSavePath (Optional, Default: "") : グラフをPNG形式で保存する際のファイルパスを指定します。指定しない場合は保存されません。
- dSize (Optional, Default: 6) : グラフのフォントサイズを調整します。
- blScale (Optional, Default: True) : グラフに目盛を表示するかどうかを指定します。Trueで表示、Falseで非表示。
- blUsageGuide (Optional, Default: True) : グラフの凡例(ラベル)を表示するかどうかを指定します。Trueで表示、Falseで非表示。
- blColumnHeading (Optional, Default: True) : グラフに列の見出しを表示するかどうかを指定します。Trueで表示、Falseで非表示。
これらのオプションを活用することで、柔軟にグラフのカスタマイズが可能です。例えば、フォントを変更したり、目盛や凡例を非表示にしたりすることができます。
参考
面積グラフの色はエクセルのブックで指定しているテーマの色を使用しています。
Office TANAKA - テーマの色について