系列が1つのグラフを大量連続作成（Excel VBA）

2021/1/17 Excel, Excel VBA マクロ, Excel VBA マクロ グラフ

【本日のミッション】

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

現実的に意味のないグラフになっていますが、サンプルということでご了承ください。
今回は下記データを使わせていただき、グラフにしやすい表に加工しました。

労働力調査 長期時系列表 失業期間別完全失業者数 － 全国

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


・
・

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

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

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

グラフを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 t_row_d As Long '対象データ行
    Dim t_row_c As Long 'グラフ貼付行
    
    Application.ScreenUpdating = False
    
    '■変数セット
    Set cht_m = ActiveSheet.ChartObjects("グラフ 1").Chart   '元グラフ
    t_row_d = 8     '対象データ行（2003年開始行）
    t_row_c = 14    'グラフ貼付行（2003年開始行）
    c_no = 2        'グラフ番号
    
    '■前回作成グラフを削除
    For c_ct = ActiveSheet.ChartObjects.Count To 1 Step -1
    
        '□元グラフ（グラフ 1）以外削除
        If ActiveSheet.ChartObjects(c_ct).Name <> "グラフ 1" Then
            ActiveSheet.ChartObjects(c_ct).Delete
        End If
    Next c_ct
    
    '■表の2003年から順に処理
    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
        
        '□グラフ参照変更
        fml1 = Cells(t_row_d, 1).Address(External:=True)                               '系列名・タイトル用セル
        fml2 = Range(Cells(t_row_d, 2), Cells(t_row_d + 3, 2)).Address(External:=True) '軸ラベル用セル
        fml3 = Range(Cells(t_row_d, 3), Cells(t_row_d + 3, 3)).Address(External:=True) '系列値用セル
        
        cht.ChartTitle.Formula = "=" & fml1 'グラフタイトル変更
        cht.SeriesCollection(1).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & ",1)"   'グラフデータ参照先変更
        t_row_d = t_row_d + 4       '対象データ行+4（次年行）
        t_row_c = t_row_c + 10      'グラフ貼付行  （次年グラフ貼付行）
    Loop

    Application.ScreenUpdating = True

End Sub

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

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


・
・
               

■スポンサーリンク

■おおまかなVBA処理の流れ

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

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

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

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

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

アクティブシートに存在するグラフの個数の回数だけ、グラフ名が「グラフ 1」かどうかIF式で判定して、そうでなければ削除すればいいのですが、処理の順番には注意が必要です。

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

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

For c_ct =1 To ActiveSheet.ChartObjects.Count

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

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

そうならないように削除処理を行うときは、個数の最大値→1という順番にします。

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

■元グラフの準備

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

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

グラフのタイトルも、セル参照にしています。

元グラフの名前は「グラフ 1」にしておきます。
元グラフを選択し、[ホーム]－[編集]－[検索と選択]ー[オブジェクトの選択と表示]

■処理行の変更

処理開始時の行番号から、次年のデータ処理に移行する際、

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

としています。

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

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

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

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

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

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

そこです！！！

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

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

■グラフコピー

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

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

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

■グラフ参照先変更

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

=SERIES(Sheet1!$A$4,Sheet1!$B$4:$B$7,Sheet1!$C$4:$C$7,1)

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

今回は系列は一つだけなので系列番号は変更しません。
それ以外の値をセルアドレス形式で、変数fml1～fml3に格納します。

fml1＝系列名
fml2＝横軸ラベルの範囲
fml3＝データ範囲 

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

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

fml1 = Cells(t_row_d, 1).Address(External:=True)                               '系列名・タイトル用セル
fml2 = Range(Cells(t_row_d, 2), Cells(t_row_d + 3, 2)).Address(External:=True) '軸ラベル用セル
fml3 = Range(Cells(t_row_d, 3), Cells(t_row_d + 3, 3)).Address(External:=True) '系列値用セル
cht.SeriesCollection(1).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & ",1)" 'グラフデータ参照先変更

グラフのタイトルも、セル参照にしています。

cht.ChartTitle.Formula = "=" & fml1

今回はシンプルなグラフのコピーをご紹介させていただきました。
大量にあるデータの傾向をつかむには、グラフにして可視化するとわかりやすいですよね。

FormulaプロパティやAddressの使い方、複数系列グラフの大量連続コピーなどにつきましては、また後日投稿させていただきますね。

■スポンサーリンク

■ランキングに参加しています。
↓このブログを気に入っていただけましたら、ポチッとお願いします。
にほんブログ村 IT技術ブログへ
にほんブログ村