面積グラフとは

面積グラフは、各項目の割合を縦横両方向に100%積み上げて面積で示すグラフです。例えば、以下のようなデータがあるとします。

このデータを基に作成される面積グラフは次のようになります。

面積グラフは、データの割合を視覚的に分かりやすく示すのに非常に便利です。

厚労省が策定しているデータヘルス計画の中で、健康分布図としても使われていたりします。
面積グラフのほかに、マリメッコチャート、マリメッコグラフ、メッコチャート、面積図などと呼ばれることもあるようです。

この記事の要点

面積グラフをVBAで次のように指定して作ります。

'SetMensekizu データ範囲, グラフ作成範囲
SetMensekizu Range("B2:E4"), Range("B7:E20")

データ範囲には、この記事の最初に紹介したような項目名のあるデータのセル範囲を指定します。

なぜVBAで作るのか

エクセルの標準機能にあるツリーマップでも、各項目を面積で表すことができますが、１項目に対する面積を表すためのもので、面積グラフのように2項目を表すことを目的とはしていません。
また、次のリンク先のように、エクセルの標準機能でも面積グラフを一応作ることができるようですが、グラフを作成するための作業用の表を作る必要があり、ちょっと面倒です。
BIZPERA - 【5分でわかる】マリメッコグラフはExcelで作れる
 think-cell - メッコチャートとは？使い方やExcelでの作成方法を解説

この作業用の表を作るのが面倒でないとか、一度作ればいい場合は、上記リンクの方法をお勧めしますが、そんな表を作るのが面倒過ぎるという方は、この記事の方法をお試しください。

VBAコード

以下のコードを標準モジュールに貼り付け、Main_MakeMensekizu()内のセル範囲を適宜変更してください。データ範囲とグラフの貼り付け範囲を指定します。Range("B2:E4")のような書き方もＯＫです。

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 - テーマの色について