Excel VBA 選択したグラフの書式・大きさにグラフを統一する

はじめに

マクロを使い、エクセルファイル内にある複数の同じ形式のグラフの書式や大きさを統一する方法について考えたい。

マクロ作成の経緯

複数の同じ形式のグラフの書式や大きさを調整する際に、1つ変更すれば、他のグラフにも、その変更を適用できたらと考えたのがきっかけだった。

作成したマクロの概要

エクセルのグラフテンプレート機能を使い、選択したグラフのテンプレートファイルを一時的に作成し、他の同じ形式のグラフに適用する。

動作手順

1. グラフが選択されているか確認
2. 選択されているグラフの幅・高さ・グラフの種類を取得
3. 選択されているグラフのテンプレートを保存
4. 書式・大きさを適用するか、軸ラベルを追加するかどうかのメッセージを表示
5. 各シートのグラフに対して、同じグラフの種類かどうかを確認
6. 同じグラフ種類の場合、テンプレート適用、大きさ調整、グラフタイトル再設定、軸ラベル追加・再設定を行う
7. 保存したグラフのテンプレートを削除

注意点

• Chart.ChartTypeプロパティで返されるグラフの種類(XlChartType)で同じ形式か判断するため、見た目は同じでも、違うグラフの場合がある

※2025/10/18 追記
適用されるグラフのグラフタイトルに数式を設定していた場合、数式が値になってしまう、また、軸ラベルがなぜかすべて「タイトル」表記になってしまう問題に対応した。
グラフタイトルは数式を再設定し、軸ラベルについては、軸グラフの再設定・追加について、メッセージを表示し、以下の条件で対応を分けた。

• 選択したグラフに軸ラベルがない場合は、適用されるグラフの軸ラベルを削除

選択したグラフに軸ラベルがある場合は、軸ラベルを追加するかどうかで以下の通りとした。

• 軸ラベルを追加するとした場合、適用されるグラフに軸ラベルがなければ、選択したグラフと同じ軸ラベルを追加
• 軸ラベルを追加しないとした場合、適用されるグラフに軸ラベルがなければ、そのまま軸ラベルはなしとする
• 追加するしないにかかわらず、適用されるグラフにすでに軸ラベルがある場合は、変更せず、再設定を行う

完成したマクロ

ApplySameFormatCharts

Public Sub ApplySameFormatCharts()

Dim TemplateChartObject As ChartObject
Dim TemplateChartName As String
Dim TemplateChartWidth As Double
Dim TemplateChartHeight As Double
Dim TemplateChartType As XlChartType
Dim TemplateAxesFormulas As Collection

Dim Rtn_Size As Long
Dim Rtn_Temp As Long
Dim Rtn_Axes As Long

Dim TargetSheet As Worksheet
Dim TargetChartObject As ChartObject
Dim ChartTitleFormula As String
Dim TargetChartAxes As Axes
Dim ChartAxesFormulas As Collection
Dim i As Long

    If ActiveChart Is Nothing Then    
        MsgBox "グラフが選択されていません。グラフを選択してから実行してください。"
        Exit Sub
    End If
    
    Set TemplateChartObject = ActiveChart.Parent
    TemplateChartWidth = TemplateChartObject.Width
    TemplateChartHeight = TemplateChartObject.Height
    TemplateChartType = TemplateChartObject.Chart.ChartType
    TemplateChartName = ThisWorkbook.Path & "\グラフテンプレート" & Format(Now, "yymmdd_hhmmss")
    TemplateChartObject.Chart.SaveChartTemplate TemplateChartName
    
    'テンプレートグラフの軸ラベルを取得
    Set TargetChartAxes = TemplateChartObject.Chart.Axes
    Set TemplateAxesFormulas = New Collection
    i = 1
    Do Until i > TargetChartAxes.Count
        If TargetChartAxes.Item(i).HasTitle Then
            TemplateAxesFormulas.Add TargetChartAxes.Item(i).AxisTitle.Formula, "Item" & i
        Else
            TemplateAxesFormulas.Add "なし", "Item" & i
        End If
        i = i + 1
    Loop

    Rtn_Temp = MsgBox("選択中のグラフの書式を適用しますか？", vbYesNo + vbQuestion)
    Rtn_Size = MsgBox("選択中のグラフの大きさを適用しますか？", vbYesNo + vbQuestion)
    Rtn_Axes = MsgBox("選択中のグラフの軸ラベルを追加しますか？", vbYesNo + vbQuestion)
    
     For Each TargetSheet In ActiveWorkbook.Sheets
        For Each TargetChartObject In TargetSheet.ChartObjects
            'グラフタイトルを取得
            ChartTitleFormula = ""
            If TargetChartObject.Chart.HasTitle Then
                ChartTitleFormula = TargetChartObject.Chart.ChartTitle.Formula
            End If
            '軸ラベルを取得
            Set TargetChartAxes = TargetChartObject.Chart.Axes
            Set ChartAxesFormulas = New Collection
            i = 1
            Do Until i > TargetChartAxes.Count
                If TargetChartAxes.Item(i).HasTitle Then
                    ChartAxesFormulas.Add TargetChartAxes.Item(i).AxisTitle.Formula, "Item" & i
                Else
                    ChartAxesFormulas.Add "なし", "Item" & i
                End If
                i = i + 1
            Loop

            If TargetChartObject.Chart.ChartType = TemplateChartType Then
                If Rtn_Temp = vbYes Then
                    TargetChartObject.Chart.ApplyChartTemplate (TemplateChartName)
                    'グラフタイトル数式再設定
                    If ChartTitleFormula <> "" Then
                        TargetChartObject.Chart.ChartTitle.Formula = ChartTitleFormula
                    End If
                    '軸ラベルを再設定
                    i = 1
                    Set TargetChartAxes = TargetChartObject.Chart.Axes
                    Do Until i > TargetChartAxes.Count
                        If TargetChartAxes.Item(i).HasTitle And ChartAxesFormulas("Item" & i) <> "なし" Then
                            TargetChartAxes.Item(i).AxisTitle.Formula = ChartAxesFormulas("Item" & i)
                        Else
                            If TargetChartAxes.Item(i).HasTitle And Rtn_Axes = vbYes Then
                                TargetChartAxes.Item(i).AxisTitle.Formula = TemplateAxesFormulas("Item" & i)
                            Else
                                '軸ラベルを削除
                                Select Case TargetChartAxes.Item(i).Type
                                    Case xlValue
                                        TargetChartObject.Chart.SetElement (msoElementPrimaryValueAxisTitleNone)
                                    Case xlCategory
                                        TargetChartObject.Chart.SetElement (msoElementPrimaryCategoryAxisTitleNone)
                                End Select
                            End If
                        End If
                        i = i + 1 
                    Loop
                End If
                If Rtn_Size = vbYes Then
                    TargetChartObject.Width = TemplateChartWidth
                    TargetChartObject.Height = TemplateChartHeight
                End If
            End If
        Next TargetChartObject
    Next TargetSheet
    Kill TemplateChartName & ".crtx"
End Sub

サンプルファイル：

更新履歴

2025/03/05：新規投稿
2025/10/18：グラフタイトルの再設定、軸ラベルの再設定・追加処理を追加