複数列の積上げ棒グラフ ラベルのセンタリング

複数系列の積上棒グラフ

業績計画を図示する場合、事業ごとに積上げたグラフを作成することがよくあります。

しかし、エクセルのグラフ機能では、積上げグラフまたは複数列グラフしか作成できません。

複数列の積上げ棒グラフ

実務上は、空欄の列を使用して、内部的には単一列の積上げグラフだが、見た目は複数列になっているグラフを作るのが一般的です。

空欄の列は、系列と系列の間のスペースのように見えます。このため、最初と最後にも空欄の列が必要です。

2系列で積み上げているように見えるこのグラフは、実際には6系列を積み上げています。

ラベルの位置

この方法では、ラベルを中央に表示することができません。

そのため、資料の細かな体裁を気にする企業では、テキストボックスに入力して手動で調整するという方法をとるようです。

この部分を自動化します。

マクロの要件

• シート上のラベルから、テキストボックスを作成する
• テキストボックスを適切に配置する
• 実績期間の年数、予想期間の年数、予想期間のシナリオ数に基づく

サンプルコード

呼び出し用
2パターン用意している

Sub Case_Comparizon_Chart_Axis()

    ' Constants
    Dim actual_count As Integer
    Dim projected_count As Integer
    Dim case_count As Integer

    actual_count = 3
    projected_count = 5
    case_count = 2

    ' Call subroutine
    Call Case_Comparizon_Chart("Axis", actual_count, projected_count, case_count)

End Sub

Sub Case_Comparizon_Chart_Data()

    ' Constants
    Dim actual_count As Integer
    Dim projected_count As Integer
    Dim case_count As Integer

    actual_count = 3
    projected_count = 5
    case_count = 2

    ' Call subroutine
    Call Case_Comparizon_Chart("Data", actual_count, projected_count, case_count)

End Sub

本体

Sub Case_Comparizon_Chart(label_type As String, actual_count As Integer, projected_count As Integer, case_count As Integer)

    Application.ScreenUpdating = False

    ' Iterators
    Dim i_year As Integer
    Dim i_case As Integer
    Dim i_element As Integer

    ' Constants
    Dim plotarea_width As Double
    plotarea_width = 450

    ' Variables
    Dim label_width As Double
    Dim label_range As Range
    Dim label_lefts As Variant      ' .Left = Center of label shapes
    Dim label_shapes As Variant     ' For Grouping Only

    Set label_range = Selection
    label_width = plotarea_width / (2 * actual_count + (1 + case_count) * projected_count + 1)

    ' Fix number of elements
    Select Case label_type
    Case "Axis"
        ReDim label_lefts(actual_count + projected_count - 1)
        ReDim label_shapes(actual_count + projected_count - 1)
    Case "Data"
        ReDim label_lefts(actual_count + projected_count * case_count - 1)
        ReDim label_shapes(actual_count + projected_count * case_count - 1)
    End Select

    ' Lefts of labales in actual period
    For i_year = 1 To actual_count
        label_lefts(i_year - 1) = (2 * i_year - 0.5) * label_width
    Next i_year

    ' Lefts of labales in projected period
    Select Case label_type
    Case "Axis"
        ' This arithmetic progression is bit complex
        For i_year = 1 To projected_count
            label_lefts(i_year + actual_count - 1) _
                = (actual_count * 2 - case_count / 2 + (case_count + 1) * i_year) * label_width
        Next i_year

    Case "Data"
        ' This arithmetic progression is bit complex
        For i_year = 1 To projected_count
            For i_case = 1 To case_count
                label_lefts(actual_count + (i_year - 1) * case_count + i_case - 1) _
                    = (1 + actual_count * 2 + (case_count + 1) * (i_year - 1) + (i_case - 0.5)) * label_width
            Next i_case
        Next i_year

    End Select

    ' Place textboxes based on label_lefts
    For i_element = 0 To UBound(label_lefts)
        Call Insert_Label(label_range(i_element + 1).Value, label_lefts(i_element))
        Set label_shapes(i_element) = Selection
    Next i_element

    ' Grouping
    label_shapes(0).Select
    For i_element = 1 To UBound(label_shapes)
        label_shapes(i_element).Select False
    Next i_element
    Selection.Group.Select

    ' Adjust position
    With Selection
        .Top = label_range.Top + 30
        .Left = label_range.Left
    End With

End Sub

Sub Insert_Label(ByVal label_text As String, ByVal label_left As Double)

    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 50, 50, 50, 50).Select

    With Selection

        With .ShapeRange

            With .TextFrame2

                With .TextRange
                    .Text = label_text
                    .Font.Bold = msoTrue
                    .Font.Size = 8
                    .ParagraphFormat.Alignment = msoAlignCenter
                    .Font.Name = "Arial"
                End With

                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
                .AutoSize = msoAutoSizeShapeToFitText

            End With

            .Width = 50
            .Top = 10
            .Left = label_left - .Width / 2

        End With

    End With

End Sub

構造

• 位置を計算する等差数列はわかりづらいが、これ以外に難しい部分は特にない
• 系列数とプロットエリアの幅から、棒グラフの棒の位置を特定する
• ラベルの数だけ「テキストボックスを挿入 => 棒グラフの位置に移動」を繰り返す

Memo

テキストボックスの挿入

' 位置・サイズはあとから調整するので、Leftなどの値はダミーでよい
ActiveSheet.Shapes.AddLabel msoTextOrientationHorizontal, Left, Top, Width, Height
' ()書きすればSelectメソッドなどを使える
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 50, 50, 50, 50).Select

テキストボックスの文字列

' オブジェクトの構造はそれなりに複雑で、Selectionから操作するのが最もシンプル
Selection.ShapeRange.TextFrame2.TextRange.Text = "文字列"

グループ化

' 単純化のため、Shapeは配列に格納してある
label_shapes(0).Select

For e = 1 To UBound(label_shapes)
    ' Select Falseで、選択中のオブジェクトの選択を解除せずに選択
    label_shapes(e).Select False
Next 

' グループ化しておくと移動やサイズの微調整がしやすくなる
Selection.Group.Select