【本日のミッション】
Excel VBAにて、1つのグラフを元に、複数系列の参照データ数が異なる月別グラフを自動大量作成せよ。
目次
ミッションの概要
今回は気象庁 過去の気象データを使用させて頂きました。
那覇・大阪・北海道の日別の平均気温データ 2020年1月16日から2021年4月8日までのデータを使用して、月別のグラフを作成します。
今回のデータは、A列に日付・B~D列に平均気温のデータが入っています。
そして、各月でデータの数(日数)が異なります。
データに欠損が存在する場合、その日のデータを飛ばした形でグラフを作る仕様にします。
私は大量のグラフを作成するときは、
- 元になるグラフを1つ作る。
- そのグラフをコピーして参照先を変更するVBAを作成する。
という手順にしています。
今回は2020年1月のグラフを「グラフ_202001」という名前で、あらかじめ作成しておきます。マクロで作るのは2020年2月からのグラフになります。
グラフを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 kei As Long '系列番号
'行列関連
Dim t_row_d As Long '処理対象行
Dim s_row_d As Long 'グラフ参照 開始行
Dim e_row_d As Long 'グラフ参照 終了行
Dim t_row_c As Long 'グラフ貼付行
'その他
Dim ym As Date '処理対象年月(1日)
Dim Next_ym As Date '処理対象次年月(1日)
Dim n As Long '処理対象行増加用
Application.ScreenUpdating = False
'■変数セット
Set cht_m = ActiveSheet.ChartObjects("グラフ_202001").Chart '元グラフ
ym = #2/1/2020# '処理対象年月(1日)
Next_ym = WorksheetFunction.EDate(ym, 1) '処理対象次年月(1日)
s_row_d = 0 'グラフ参照 開始行
t_row_d = 2 '処理対象行
t_row_c = 13 'グラフ貼付行(2020年2月)
n = 0 '処理対象行増加用
'■前回作成グラフを削除
For c_ct = ActiveSheet.ChartObjects.Count To 1 Step -1
'□元グラフ「グラフ_202001」以外削除
If Not ActiveSheet.ChartObjects(c_ct).Chart Is cht_m Then
ActiveSheet.ChartObjects(c_ct).Delete
End If
Next c_ct
'■表の2行目(t_row_d)から順に処理
Do While Cells(t_row_d, 1) <> "" '表のデータが空欄になったら終了
'□グラフ参照開始行・終了行の取得
Do While Cells(t_row_d + n, 1) < Next_ym And Cells(t_row_d + n, 1) <> ""
'グラフ参照 開始行
If Month(Cells(t_row_d + n, 1)) = Month(ym) And s_row_d = 0 Then
s_row_d = t_row_d + n
End If
'グラフ参照 終了行
If Month(Cells(t_row_d + n + 1, 1)) = Month(Next_ym) Or Cells(t_row_d + n + 1, 1) = "" Then
e_row_d = t_row_d + n
End If
n = n + 1
Loop
'□グラフのコピー
cht_m.ChartArea.Copy '元グラフをコピー
Cells(t_row_c, 6).Select 'グラフ貼付セル選択
ActiveSheet.Paste 'グラフ貼付
Set cht = ActiveChart '変数cht=処理対象グラフ
cht.Parent.Name = "グラフ_" & Format(Cells(s_row_d, 1), "yyyymm") 'グラフ名変更
cht.ChartTitle.Formula = Format(Cells(s_row_d, 1), "yyyy年m月") 'グラフタイトル変更
'□グラフ参照変更
For kei = 1 To 3 '系列番号1~3
'□グラフ参照変更
fml1 = Cells(1, kei + 1).Address(External:=True) '系列名用セル範囲
fml2 = Range(Cells(s_row_d, 1), Cells(e_row_d, 1)).Address(External:=True) '系列値用セル範囲
fml3 = Range(Cells(s_row_d, kei + 1), Cells(e_row_d, kei + 1)).Address(External:=True) '軸ラベル範囲用セル範囲
cht.SeriesCollection(kei).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & "," & kei & ")" 'グラフデータ参照先変更
Next kei
t_row_c = t_row_c + 11 'グラフ貼付行 (次月グラフ貼付行)
t_row_d = e_row_d + 1 '前月グラフ最終行+1
s_row_d = 0 'グラフ参照 開始行 初期化
n = 0 '処理対象行増加用 初期化
ym = WorksheetFunction.EDate(ym, 1) '処理対象年月
Next_ym = WorksheetFunction.EDate(ym, 1) '処理対象次年月
Loop
Application.ScreenUpdating = True
End Sub
記入したモジュールのどこかにカーソルを置いてF5キーをクリックしてください。
Excelのシートに、2020年2月~2021年4月のグラフが出来上がります。
・
・
おおまかなVBA処理の流れ
- 前回作成のグラフが存在する場合(2回目以降の修正処理を考慮)、元グラフの「グラフ_202001」以外削除しておく。
- 表データを2行目から順に処理を行い、グラフ参照先に使用する、
- 変数「s_row_d」に対象月の開始行を格納する。
- 変数「e_row_d」に対象月の最終行を格納する。
- 元グラフ「グラフ_202001」をコピーする。
グラフのコピーは11行おきとする。 - グラフの名前を変更する。「グラフ_yyyymm」とする。
- グラフタイトルを対象年月に変更する。
- 変数「s_row_d」「e_row_d」を使ってグラフデータ参照先(系列1~3)を変更する。
何度でも修正を繰り返すことができるVBAにしておく
こういうデータは、フォーマットの変更の可能性が高いので、何度でも繰り返し修正処理ができるようにしておきます。
下記処理は、「グラフ_202001」以外のグラフを削除する内容です。
「グラフ_202001」はコピー元グラフとして使用するので削除しません。
For c_ct = ActiveSheet.ChartObjects.Count To 1 Step -1
'□元グラフ「グラフ_202001」以外削除
If Not ActiveSheet.ChartObjects(c_ct).Chart Is cht_m Then
ActiveSheet.ChartObjects(c_ct).Delete
End If
Next c_ct
アクティブシートに存在するグラフ全てについて、「グラフ_202001」でなければ削除すればいいのですが、処理の順番に注意が必要です。
IF判定で、グラフが削除された時点で、アクティブシート全体のグラフの個数が変わります。
もし処理の順番が「1つ目のグラフ」→「アクティブシートの全グラフの個数」だとしたら・・・↓↓↓
For c_ct =1 To ActiveSheet.ChartObjects.Count
処理開始時は「ActiveSheet.ChartObjects.Count=16」だったとして、途中でグラフが1個削除されたら・・・「ActiveSheet.ChartObjects.Count=15」になってしまいます。
そんな処理が繰り返されるので、グラフは一つおきに削除され、最後にはエラーが出て止まってしまいます。
そうならないように削除処理を行うときは「Step -1」を使って、「アクティブシートの全グラフの個数」→「1つ目のグラフ」という順番にします。
参考:ワークシート内のグラフを「グラフ 元」以外全て削除(Excel VBA)
元グラフの準備
元グラフは丁寧に作ります。
VBAを一通り処理した後、全てのグラフを確認し、必要であれば最大値や最小値の数値(統一する場合)、項目軸の位置の調整(全てのグラフで正しく表示されるように)などを行い、再度VBA処理を行います。
今回のグラフの参照先は、下記の通りです。
元グラフの名前は2020年1月のグラフなので「グラフ_202001」にしておきます。
(初期値の「グラフ 1」のままだと、ChartObjects.Nameが「Chart 1」になることがあるので、私は名前を変更しています。)
元グラフを選択し、[ホーム]-[編集]-[検索と選択]ー[オブジェクトの選択と表示]で名前を変更します。
Do While の処理順
今回の処理は2つの Do While で処理を繰り返し、行っています。
一つ目のDo While は表の2行目から処理を開始し、表が無くなったらLoopを抜けます。
二つ目のDo Whileでは、処理対象行「t_row_d」に「n」を加算(n=n+1で加算)することによって次行→次行へと処理を進め、グラフ参照 開始行「s_row_d」・終了行「e_row_d」を取得し、対象日付の月が替わる直前に(または空欄なったら)Loopを抜けます。
t_row_d = 2 '処理対象行 n = 0 '処理対象行増加用 Do While Cells(t_row_d, 1) <> "" '表のデータが空欄になったら終了 Do While Cells(t_row_d + n, 1) < Next_ym And Cells(t_row_d + n, 1) <> "" ~グラフ参照 開始行「s_row_d」・終了行「e_row_d」の取得~ n = n + 1 Loop ~グラフのコピー・参照変更処理~ t_row_d = e_row_d + 1 '前月グラフ参照最終行+1 n = 0 '処理対象行増加用 Loop
- 1つ目のDo Whileは、処理対象行「①t_row_d=2」から開始します。
- 2つ目のDo While に入ります。
「t_row_d+n」(n=n+1で加算)で次行→次行と処理を進め、グラフの開始行「2月の開始行」を「②s_row_d」に格納します。 - 更に「t_row_d+n」(n=n+1で加算)で次行→次行と処理を進め、グラフの終了行「2月の終了行」を「③e_row_d」に格納します。
(2つ目のDo Whileを抜ける) - 「②s_row_d」と「③e_row_d」を使って④グラフを作成します。
- 処理対象行「①’t_row_d」に「e_row_d+1」を入れる。
- 「n」を「0」に戻す。
・
・上記2~6を繰り返す。
・ - 「t_row_d」のセルが空欄になったら終了。
(1つ目のDo Whileを抜ける)
対象月グラフの参照開始行・終了行の取得
今回のグラフの参照先は、月によって異なります。参照先が変動できるような仕様にしなければいけません。
Do While Cells(t_row_d + n, 1) < Next_ym And Cells(t_row_d + n, 1) <> "" '□グラフ参照 開始行 If Month(Cells(t_row_d + n, 1)) = Month(ym) And s_row_d = 0 Then s_row_d = t_row_d + n End If '□グラフ参照 終了行 If Month(Cells(t_row_d + n + 1, 1)) = Month(Next_ym) Or Cells(t_row_d + n + 1, 1) = "" Then e_row_d = t_row_d + n End If n = n + 1 Loop
Do Whileの内容
- 処理対象の日付が、処理対象次年月(1日)「Next_ym」より小さい場合
かつ - 処理対象の日付が空欄でない場合
上記条件に合う場合は、Do While内の処理を行う・・・というものです。
【1つ目のグラフ作成時の場合】
処理対象年月(1日)「ym」=2020年2月1日
処理対象次年月(1日)「Next_ym」=2020年3月1日
処理対象の日付が2020年3月1日 より小さい場合
かつ
処理対象の日付が空欄(表が無くなる)でない場合
にDo While内の処理を行います。
言い換えると、
処理対象の日付が2020年3月1日以降になった場合、または処理対象の日付セル(A列)が空欄になった場合に、Do Whileを抜けます。
「=Next Year」としていないのは、「2020年3月1日」のデータが欠損している場合を考慮しての対応です。
グラフ参照 開始行「s_row_d」の取得
処理対象行「t_row_d」は初期値の「2」から変数「n」(n=n+1)を加算することで、次行→次行へと処理を進めます。
- 処理対象の日付の月が処理対象年月の月と同じ
かつ - グラフ参照 開始行「s_row_d」が0の場合
上記条件に合う場合、「t_row_d + n」をグラフ参照 開始行「s_row_d」に格納します。
s_row_d = t_row_d + n
s_row_dに「0」以外の数字が格納されたら、その後の処理で条件に合う日付が出てきても数字を上書きしないように「s_row_d=0」という条件を入れています。
【1つ目のグラフ作成時の場合】
処理対象年月(1日)「ym」=2020年2月1日
処理対象の日付 Cells(t_row_d + n, 1) は「n」(n=n+1)を加算することによって、次行→次行の日付へと処理を進めます。
処理対象の日付の月「1月」が、処理対象年月「ym」の月「2月」になった時の「t_row_d + n」をグラフ参照 開始行「s_row_d」に格納します。
グラフ参照 終了行「e_row_d」の取得
- 処理対象1行下のセルの日付の月が、処理対象次年月の月と同じ場合
または - 処理対象1行下のセルが空欄の場合
上記条件に合う場合、「t_row_d + n」をグラフ参照 終了行「e_row_d」に格納します。
e_row_d = t_row_d + n
表の最後の月には、「次月」データが存在しないため、「Cells(t_row_d + n + 1, 1) = “”」(処理対象の1行下のセルが空欄)という条件を入れています。
【1つ目のグラフ作成時の場合】
処理対象次年月(1日)「Next_ym」=2020年3月1日
処理対象の日付が「2020年2月29日」の時、下のセルは「2020年3月1日」になります。
処理対象次年月「Next_ym」(2020年3月1日)の月「3月」と同じため「t_row_d + n」をグラフ参照 開始行「e_row_d」に格納します。
処理対象行・グラフ貼り付け行の変更
【処理開始時の数値】 t_row_d = 2 '処理対象行 t_row_c = 13 'グラフ貼付行(2020年2月分グラフ)
【次年グラフ処理に移行する際の数値変更】 t_row_d = e_row_d + 1 '前月グラフ参照最終行+1 t_row_c = t_row_c + 11 'グラフ貼付行 (次月グラフ貼付行)
次年のグラフ作成処理に移行する際、下記の通り値を変更します。
表データの処理対象行「t_row_d」:前月グラフ参照最終行「e_row_d」 + 1
グラフ貼付行「t_row_c」:t_row_c + 11
グラフコピー
昔、ActiveSheet.ChartObjects(n).Copyで大量にグラフコピー処理をすると、すごく時間がかかって、ActiveSheet.ChartObjects(n).Chart.ChartArea.Copy で処理すると時短になったことがあって、それ以来「ChartArea」を使っていたんです。
でも、今改めて2つのコードで処理時間を比較してみたら、あんまり違いが無かったんです。PCの環境が昔と違うからかなぁ・・・。
とりあえず、今回は「ChartArea」を使ったコードにしています。
グラフ参照先を変えるとグラフの色が変わってしまう現象
Excelにはありがた迷惑な機能があります。
グラフの参照先を変えると、自動的にグラフの色が変わってしまうことがあります。
「規定の元の色に戻しておきましたよ~」と言わんばかりに。
この現象が起こった時は下記設定を変更し、再度マクロ処理を行います。
[ファイル]-[オプション]
[詳細設定]ー[グラフ]
「グラフのデータ要素の参照先が現在のブックに設定されているプロパティ」のチェックを外します。
これにチェックが付いていると、参照先を変更するたびにブックに設定されているグラフのデータ要素に戻されてしまいます。
グラフ参照先変更
今回のグラフには複数の系列があります。
元グラフ「グラフ_202001」のグラフ系列1のFormulaプロパティには、下記数式が入っています。
=SERIES(折れ線!$B$1,折れ線!$A$2:$A$17,折れ線!$B$2:$B$17,1)
=SERIES(系列名,軸ラベルの範囲,データ範囲,系列番号)
今回は系列が複数あるため、For~Nextを使って複数系列に同じ処理を施します。
For kei = 1 To 3 '系列番号1~3 ~グラフ参照変更処理~ Next kei
変数keiに格納される数字は、グラフ参照数式の系列番号に使用します。
kei=系列番号
系列番号以外の値はセルアドレス形式で、変数fml1~fml3に格納します。
fml1=系列名
fml2=横軸ラベルの範囲
fml3=データ範囲
それらをFormulaプロパティを使用して、対象系列の数式を変更します。
“=Series(” & fml1 & “,” & fml2 & “,” & fml3 & “,” & kei & “)”
fml1 = Cells(1, kei + 1).Address(External:=True) '系列名用セル範囲 fml2 = Range(Cells(s_row_d, 1), Cells(e_row_d, 1)).Address(External:=True) '系列値用セル範囲 fml3 = Range(Cells(s_row_d, kei + 1), Cells(e_row_d, kei + 1)).Address(External:=True) '軸ラベル範囲用セル範囲 cht.SeriesCollection(kei).Formula = "=Series(" & fml1 & "," & fml2 & "," & fml3 & "," & kei & ")" 'グラフデータ参照先変更
同様にグラフの名前も、グラフ開始行のセルの日付の年月を、”yyyymm” 形式にして入れています。
cht.Parent.Name = "グラフ_" & Format(Cells(s_row_d, 1), "yyyymm") 'グラフ名変更
グラフのタイトルはグラフ開始行のセルの日付の年月を、”yyyy年m月” 形式にして入れています。
cht.ChartTitle.Formula = Format(Cells(s_row_d, 1), "yyyy年m月") 'グラフタイトル変更
参照
系列が1つのグラフを自動大量連続作成(Excel VBA)
「実行時エラー 1004」を出さずに、ワークシート内のグラフを「グラフ 元」以外全て削除(Excel VBA)
グラフの参照先を変えると勝手にグラフの色が変わる現象を解決せよ
系列が複数あるグラフを自動大量連続作成(Excel VBA)
n行毎の改ページ設定 「実行時エラー1004 RangeクラスのPageBreakプロパティを設定できません」の原因(Excel VBA)
参照データ数が異なる・参照先が変動する月別グラフを自動大量連続作成(Excel VBA)
複数系列・参照データ数が異なる・参照先が変動する月別グラフを自動大量連続作成(Excel VBA)
大量の画像やグラフ等のオブジェクトで画面表示が遅いのを解決(Excel)
エクセル シートに画像が存在するかどうか(有無)を調べる方法(Excel VBA)
エクセルシート上 全てのオブジェクト(画像・図形・グラフ等)を選択し、削除する(Excel VBA)
エクセルシート上のオブジェクト(図形・画像・グラフ等)の件数を数える方法(Excel VBA)
エクセル シートにグラフが存在するかどうか(有無)を調べる方法(Excel VBA)
エクセル シートに図形が存在するかどうか(有無)を調べる方法(Excel VBA)
エクセル 選択しているセル範囲に写真が存在しているか(有無)を確認(Excel VBA)
エクセル 選択しているセル範囲にグラフが存在しているか(有無)を確認(Excel VBA)
エクセル 選択しているセル範囲に図形が存在しているか(有無)を確認(Excel VBA)
エクセル 選択セル範囲の写真を削除する(Excel VBA)
エクセル 選択セル範囲のグラフを削除する(Excel VBA)
エクセル 選択セル範囲の図形を削除する(Excel VBA)
Excel VBAでワードを起動して文字を入力操作(Excel VBA)
Excel VBAでワードを起動してエクセルの表をワードに貼付け(Excel VBA)
Excel VBAでワードを起動して エクセルのエクセルの表を図としてワードに貼付け(Excel VBA)
Word コピー貼付けした図が白い枠だけ?図が表示されない現象を解決
Excel VBAでワードを起動して グラフをワードに図として貼付け(Excel VBA)