系列が複数あるグラフを自動大量連続作成（Excel VBA）|40代シングルマザー派遣社員。正社員に転職するか悩む。

【本日のミッション】

Excel VBAにて、系列が複数あるグラフを元に、データ範囲を変更したグラフを大量連続作成せよ。

1 ミッションの概要
2 ファイルの準備とプロシージャ
3 おおまかなVBA処理の流れ
4 何度でも修正を繰り返すことができるVBAにしておく
5 元グラフの準備
6 処理行の変更
7 Do While Loopを抜けるタイミング
8 グラフコピー
9 グラフ参照先を変えるとグラフの色が変わってしまう現象
10 グラフ参照先変更
11 参照

ミッションの概要

今回は下記データを使わせていただき、グラフにしやすい表に加工しました。

過去の気象データダウンロード

今回のミッションは、この表の年毎のグラフを作りましょう！というものです。

・
・

私は大量のグラフを作成するときは、

元になるグラフを1つ作る。
そのグラフをコピーして参照先を変更するVBAを作成する。

という手順にしています。
今回は2000年のグラフを「グラフ元」という名前にして、あらかじめ作成しておきます。

グラフをVBAで一から作ると。コードが複雑になります。
それを一つ一つ作り上げるのに時間がかかりますし、VBAの処理時間も長くなってしまいます。

これが最終フォーマット！というグラフを一つだけきっちり作り上げて、それをコピーして参照先を変更・・・

という流れにしておけば、グラフのフォーマットが変更になっても、一つのグラフだけ修正して、VBAを再度処理すれば修正時間も短くて済みます。

■■■スポンサーリンク■■■

ファイルの準備とプロシージャ

表と元グラフを準備し（下記参照）、そのシートをアクティブにした状態で、Alt＋F11でVsual Basic Editerを起動します。

［挿入］－［標準モジュール］で新規モジュールを作成し、下記の通りコードを記入します。

Sub 系列が複数あるグラフを大量作成()
    '【変数】
    'グラフ関連
    Dim cht_m As Chart  '元グラフ
    Dim cht As Chart    '処理対象グラフ
    Dim fml1 As String  '系列名用セル範囲
    Dim fml2 As String  '軸ラベル用セル範囲
    Dim fml3 As String  '系列値用セル範囲
    Dim c_ct As Long    'グラフカウント（前回グラフ削除）
    Dim c_no As Long    'グラフ番号
    Dim kei As Long     '系列番号
    
    '行列関連
    Dim t_row_d As Long '対象データ行
    Dim t_row_c As Long 'グラフ貼付行
    
    Application.ScreenUpdating = False
    
    '■変数セット
    Set cht_m = ActiveSheet.ChartObjects("グラフ 元").Chart   '元グラフ
    t_row_d = 14    '対象データ行（2001年開始行）
    t_row_c = 16    'グラフ貼付行（2001年開始行）
    c_no = 2        'グラフ番号
    
    '■前回作成グラフを削除
    For c_ct = ActiveSheet.ChartObjects.Count To 1 Step -1
    
        '□元グラフ（グラフ 元）以外削除
        If ActiveSheet.ChartObjects(c_ct).Name <> "グラフ 元" Then
            ActiveSheet.ChartObjects(c_ct).Delete
        End If
    Next c_ct
    
    '■表の2001年から順に処理
    Do While Cells(t_row_d, 1) <> "" '表のデータが空欄になったら終了
    
        '□グラフのコピー
        cht_m.ChartArea.Copy            '元グラフをコピー
        Cells(t_row_c, 6).Select        'グラフ貼付セル選択
        ActiveSheet.Paste               'グラフ貼付
        Set cht = ActiveChart           '変数cht=処理対象グラフ
        cht.Parent.Name = "グラフ " & c_no  'グラフ名前変更
        c_no = c_no + 1                 'グラフ番号
        
         '□グラフ参照変更
         For kei = 1 To 3   '系列番号1～3
            
            fml1 = Cells(1, kei + 1).Address(External:=True)                                            '系列名
            fml2 = Range(Cells(t_row_d, 1), Cells(t_row_d + 11, 1)).Address(External:=True)             '軸ラベル用セル
            fml3 = Range(Cells(t_row_d, kei + 1), Cells(t_row_d + 11, kei + 1)).Address(External:=True) '系列値用セル
            
            cht.SeriesCollection(kei).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & "," & kei & ")"   'グラフデータ参照先変更
        
        Next kei
        
        cht.ChartTitle.Formula = Year(Cells(t_row_d, 1)) & "年 平均気温（℃）" 'グラフタイトル変更
        
        t_row_d = t_row_d + 12      '対象データ行+12（次年行）
        t_row_c = t_row_c + 14      'グラフ貼付行+14（次年グラフ貼付行）
    Loop

    Application.ScreenUpdating = True

End Sub

記入したプロシージャのどこかにカーソルを置いてF5キーをクリックしてください。

Excelのシートに、2001年（グラフ 2）～2020年（グラフ 21）が出来上がります。

・
・

■■■スポンサーリンク■■■

おおまかなVBA処理の流れ

前回作成のグラフが存在する場合（2回目以降の修正処理を考慮）、元グラフの「グラフ元」以外削除しておく。
表データを上から順に処理を行い、表データがなくなった時点で処理を終了する。
表データは12行ごとの処理とする。
元グラフ「グラフ元」をコピーする。
グラフのコピー行は14行おきとする。
グラフの名前を変更する。「グラフ 2」から番号＋1としていく。
グラフデータ参照先を変更する。
グラフタイトルを変更する。

何度でも修正を繰り返すことができるVBAにしておく

こういうデータは、フォーマットの変更の可能性が高いので、何度でも繰り返し修正処理ができるようにしておきます。

下記処理は、名前が「グラフ元」以外のグラフを削除する内容です。
「グラフ元」はコピー元グラフとして使用するので削除しません。

'■前回作成グラフを削除
For c_ct = ActiveSheet.ChartObjects.Count To 1 Step -1
    '□元グラフ（グラフ 元）以外削除
    If ActiveSheet.ChartObjects(c_ct).Name <> "グラフ 元" Then
        ActiveSheet.ChartObjects(c_ct).Delete
    End If
Next c_ct

アクティブシートに存在するグラフ全てについて、グラフ名が「グラフ元」でなければ削除すればいいのですが、処理の順番に注意が必要です。

IF判定で、グラフが削除された時点で、アクティブシート全体のグラフの個数が変わります。

もし処理の順番が「1つ目のグラフ」→「アクティブシートの全グラフの個数」だとしたら・・・↓↓↓

For c_ct =1 To ActiveSheet.ChartObjects.Count

処理開始時は「ActiveSheet.ChartObjects.Count＝21」だったとして、途中でグラフが1個削除されたら・・・「ActiveSheet.ChartObjects.Count＝20」になってしまいます。

そんな処理が繰り返されるので、グラフは一つおきに削除され、最後にはエラーが出て止まってしまいます。

そうならないように削除処理を行うときは「Step -1」を使って、「アクティブシートの全グラフの個数」→「1つ目のグラフ」という順番にします。

参考：ワークシート内のグラフを「グラフ元」以外全て削除（Excel VBA）

元グラフの準備

元グラフは丁寧に作ります。
VBAを一通り処理した後、全てのグラフを確認し、必要であれば最大値や最小値の数値(統一する場合)、項目軸の位置の調整（全てのグラフで正しく表示されるように）などを行い、再度VBA処理を行います。

今回のグラフの参照先は、下記の通りです。

元グラフの名前は「グラフ元」にしておきます。
（初期値の「グラフ 1」のままだと、ChartObjects.Nameが「Chart 1」になることがあるので、私は「グラフ元」という名前にしています。）
元グラフを選択し、[ホーム]－[編集]－[検索と選択]ー[オブジェクトの選択と表示]で名前を変更します。

処理行の変更

次年のグラフ作成処理に移行する際、

表データの行番号：「＋12」
グラフ貼付行：「＋14」

としています。

【処理開始時の数値】
t_row_d = 14    '対象データ行（2001年開始行）
t_row_c = 16    'グラフ貼付行（2001年開始行

【次年のグラフ作成処理に移行する際の数値変更】
t_row_d = t_row_d + 12      '対象データ行+12（次年行
t_row_c = t_row_c + 14      'グラフ貼付行+14（次年グラフ貼付行）

Do While Loopを抜けるタイミング

データの処理順は、上記「■処理行の変更」の通りですが、いつまでも永遠に続けるわけではありません。

t_row_d = t_row_d + 12      '対象データ行+12（次年行）

を続けていくと、いつか「t_row_d＝254」になる瞬間が訪れます。

そこです！！！

Do While Cells(t_row_d, 1) <> "" '表のデータが空欄になったら終了

Cells(t_row_d, 1)はセルA254です。
セルA254が空欄だと判断されて、Do While Loopを抜け、次の処理へ移ります。

グラフコピー

昔、ActiveSheet.ChartObjects(n).Copyで大量にグラフコピー処理をすると、すごく時間がかかって、ActiveSheet.ChartObjects(n).Chart.ChartArea.Copy で処理すると時短になったことがあって、それ以来「ChartArea」を使っていたんです。

でも、今改めて2つのコードで処理時間を比較してみたら、あんまり違いが無かったんです。PCの環境が昔と違うからかなぁ・・・。

とりあえず、今回は「ChartArea」を使ったコードにしています。

グラフ参照先を変えるとグラフの色が変わってしまう現象

Excelにはありがた迷惑な機能があります。
グラフの参照先を変えると、自動的にグラフの色が変わってしまうことがあります。
「規定の元の色に戻しておきましたよ～」と言わんばかりに。

この現象が起こった時は下記設定を変更し、再度マクロ処理を行います。

［ファイル］－［オプション］

［詳細設定］ー［グラフ］
「グラフのデータ要素の参照先が現在のブックに設定されているプロパティ」のチェックを外します。
これにチェックが付いていると、参照先を変更するたびにブックに設定されているグラフのデータ要素に戻されてしまいます。

参考：グラフの参照先を変えると勝手にグラフの色が変わる現象を解決

グラフ参照先変更

元グラフのグラフ系列1のFormulaプロパティには下記数式が入っています。

=SERIES(Sheet2!$B$1,Sheet2!$A$2:$A$13,Sheet2!$B$2:$B$13,1)

=SERIES(系列名,横軸ラベルの範囲,データ範囲,系列番号)

系列名、横軸ラベルの範囲、データ範囲はセルアドレス形式で、変数fml1～fml3に格納します。
系列は3つあるので、For kei = 1 To 3 ～ Next で1～3回繰り返して、系列番号を取得するようにしています。

fml1＝系列名
fml2＝横軸ラベルの範囲
fml3＝データ範囲
kei＝系列番号 1～3

これらをFormulaプロパティを使用して、対象系列の数式を変更します。

“=Series(” & fml1 & “,” & fml2 & “,” & fml3 & kei & “)”

For kei = 1 To 3 '系列番号1～3
    fml1 = Cells(1, kei + 1).Address(External:=True) '系列名
    fml2 = Range(Cells(t_row_d, 1), Cells(t_row_d + 11, 1)).Address(External:=True) '軸ラベル用セル
    fml3 = Range(Cells(t_row_d, kei + 1), Cells(t_row_d + 11, kei + 1)).Address(External:=True) '系列値用セル
    cht.SeriesCollection(kei).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & "," & kei & ")" 'グラフデータ参照先変更
Next kei

グラフのタイトルには「A列の年」& “年平均気温（℃）”のテキストを使用しています。

cht.ChartTitle.Formula = Year(Cells(t_row_d, 1)) & "年 平均気温（℃）"

大量にあるデータの傾向をつかむには、グラフにして可視化するとわかりやすいですよね。

参照

■■■スポンサーリンク■■■