【本日のミッション】
Excel VBAにて、系列が1つのグラフを元に、データ範囲を変更したグラフを大量連続作成せよ。
現実的に意味のないグラフになっていますが、サンプルということでご了承ください。
今回は下記データを使わせていただき、グラフにしやすい表に加工しました。
今回のミッションは、この表の年毎のグラフを作りましょう!というものです。
・
・
私は大量のグラフを作成するときは、
- 元になるグラフを1つ作る。
- それをコピーして参照先を変更する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処理の流れ
- 前回作成のグラフが存在する場合(2回目以降の修正処理を考慮)、元グラフの「グラフ 1」以外削除しておく。
- 表データを上から順に処理を行い、表データがなくなった時点で処理を終了する。
表データは4行ごとの処理とする。 - 表データがある場合、元グラフ「グラフ 1」をコピーする。
グラフのコピー行は10行ごとの処理とする。 - グラフの名前を変更する。「グラフ 2」から番号+1としていく。
- グラフタイトル参照先を変更する。
- グラフデータ参照先を変更する。
■何度でも修正を繰り返すことができる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の使い方、複数系列グラフの大量連続コピーなどにつきましては、また後日投稿させていただきますね。
■スポンサーリンク
■ランキングに参加しています。 ↓このブログを気に入っていただけましたら、ポチッとお願いします。
にほんブログ村