VBAでGANTのグラフを作成したい

質問

office365

①GANT_DATAシートに計画と実績のGANTデータ
②GANTシートにガントのグラフを表示
したいです。

①を元に②のグラフを自動で作成したい

ガント表示させる構成は
kotei1からkotei6までの計画開始計画終了実績開始実績終了の日時データがあり、Serial1からSerial2,Serial3とGANT_DATAのA列でデータがなくなるまでのガントグラフを表示。
Serialは＋30行毎に計画と実績データをデータベースから持ってくる構成。

現状は、GANTシートにひな形としてのグラフを用意しておき、
データ範囲等を１ケ１ケグラフへ反映させてガントのグラフを表示させています。
下記のイメージです。

GANTシートでのSerial1のグラフは
グラフデータの範囲：=GANT_DATA!$A$9:$C$20

系列１の系列値：=GANT_DATA!$B$9:$B$20
系列２の系列値：=GANT_DATA!$C$9:$C$20

軸ラベルの範囲：=GANT_DATA!$A$9:$A$20

GANTシートでのSerial2のグラフは
グラフデータの範囲：=GANT_DATA!$A$39:$C$50

系列１の系列値：=GANT_DATA!$B$39:$B$50
系列２の系列値：=GANT_DATA!$C$39:$C$50

軸ラベルの範囲：=GANT_DATA!$A$39:$A$50

の様にガントシートのデータ範囲を設定しておき、
GANT_DATAへデータをデータベースから持ってきたらガントのグラフが表示できる構成にしているのですが、グラフの数が増えると上記データ範囲の設定をするのも大変なので、①のシートから②のガントグラフを自動で作成できる様にしたいです。
VBAベタで教えていただきたくよろしくお願いします。

グラフの軸設定はなんとかなると思うので、根本のグラフ表示部分を作成する構成を教えていただけたらと思います

※
GANTグラフには工程間に細く青い線をしきりで入れてます。
これも実現化であれば教えていただきたく。
現状は実線をグラフへコピペで貼り付けています。

回答No.3

HohoPapa · ベストアンサー

コードが書けたのでポストします。

・GANTシートＤ列以降は４列/24時間　です。
・マクロが書き込んでいるのは、帯状態の図と、3、23、43...行の日付です。
　他の罫線やｂ列などは手作業で埋める前提です。
・計画開始日時>計画終了日時、実績開始日時>実績終了日時　は、エラーとせず無視しています。
・Nullの日時の場合も無視しています。
・具体的にはコードを読んでください。

不明点、間違い、改修店などあれば返信してください。

Option Explicit

'//共通定数、変数-----------------------------
Const BeltHHi = 0.6　 '行高とベルト高の比
Const SC = 30 'データブロックの行数
Const GC = 20 'ガントチャートブロックの行数
Dim BDay As Date '描写期間の開始日
Dim EDay As Date '描写期間の終了日
Dim DSht As Worksheet　'データシート
Dim GSht As Worksheet　'ガントチャートシート

'//メイン　　---------------------------------
Sub main()
　Set DSht = ThisWorkbook.Sheets("GANT_DATA")
　Set GSht = ThisWorkbook.Sheets("GANT")
　Call GetBDay_EDay
　Call DelBelt
　Call MakeBeltMain
End Sub

'//描写期間の開始日、終了日取得---------------
Sub GetBDay_EDay()
　Dim SCnt As Long 'シリーズカウンター
　Dim KCnt As Long '行程カウンター
　Dim c As Long '列カウンター

　BDay = DateSerial(3000, 1, 1)
　EDay = 0
　SCnt = 0
　Do
　　If DSht.Cells(SCnt * SC + 1, 1).Value = "" Then Exit Do
　　For KCnt = 1 To 6
　　　For c = 2 To 5
　　　　With DSht.Cells(SCnt * SC + KCnt + 1, c)
　　　　　If .Value <> "" Then
　　　　　　If .Value > EDay Then EDay = .Value
　　　　　　If .Value < BDay Then BDay = .Value
　　　　　End If
　　　　End With
　　　Next c
　　Next KCnt
　　SCnt = SCnt + 1
　Loop

End Sub

'//帯図形全数削除-----------------------------
Sub DelBelt()
　Dim SCnt As Long 'シリーズカウンター
　Dim KCnt As Long '行程カウンター
　Dim shp As Shape
　Dim wkName As String

　SCnt = 0
　For SCnt = 0 To 100
　　For KCnt = 1 To 6
　　　wkName = "Belt" & Format(SCnt, "000") & Format(KCnt, "00")
　　　On Error Resume Next
　　　Set shp = GSht.Shapes(wkName & "P")
　　　shp.Delete
　　　Set shp = GSht.Shapes(wkName & "J")
　　　shp.Delete
　　　On Error GoTo 0
　　Next KCnt
　Next SCnt

End Sub

'//帯図形全数描写-----------------------------
Sub MakeBeltMain()

　Dim SCnt As Long 'シリーズカウンター
　Dim KCnt As Long '工程カウンター
　Dim BPos As Double '左軸位置
　Dim Nm As String　　'図形名
　Dim Bx As Double　　'開始横位置
　Dim By As Double　　'開始縦位置
　Dim Hi As Double　　'高さ
　Dim Wi As Double　　'幅
　Dim Cr As Long　　'色
　Dim WperHi As Long　 '1日当たりの表示幅
　Dim TateHosei As Long
　Dim i As Long

　Hi = GSht.Rows(4).RowHeight * BeltHHi
　BPos = GSht.Cells(2, 4).Left
　WperHi = GSht.Cells(4, 8).Left - GSht.Cells(4, 4).Left
　TateHosei = GSht.Rows(4).RowHeight * ((1 - BeltHHi) / 2)
　Hi = GSht.Rows(4).RowHeight * BeltHHi
　BDay = Int(BDay)
　EDay = Int(EDay)

　SCnt = 0
　Do
　　If DSht.Cells(SCnt * SC + 1, 1).Value = "" Then Exit Do

　　GSht.Rows((SCnt * GC) + 3).ClearContents
　　For i = 0 To EDay - BDay
　　　GSht.Cells((SCnt * GC) + 3, ((i + 1) * 4)).Value = BDay + i
　　Next i

　　For KCnt = 1 To 6
　　　Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "P"
　　　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 2).Value - BDay) * WperHi)
　　　By = GSht.Cells(SCnt * GC + (KCnt * 2) + 2, 1).Top + TateHosei
　　　Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 3).Value - _
　　　　　 DSht.Cells(SCnt * SC + KCnt + 1, 2).Value) * WperHi
　　　Cr = rgbTurquoise　'計画のベルトの色
　　　MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr

　　　Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "J"
　　　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 4).Value - BDay) * WperHi)
　　　By = GSht.Cells(SCnt * GC + (KCnt * 2) + 3, 1).Top + TateHosei
　　　Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 5).Value - _
　　　　　 DSht.Cells(SCnt * SC + KCnt + 1, 4).Value) * WperHi
　　　Cr = rgbGreenYellow　'実績のベルトの色
　　　MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr

　　Next KCnt
　　SCnt = SCnt + 1
　Loop

End Sub

'//　帯描写ルーチン-----------------------
Sub MakeBelt(Sh As Worksheet, Nm As String, _
　　　 Bx As Double, By As Double, Hi As Double, Wi As Double, Cr As Long)

　Dim shp As Shape

　On Error Resume Next
　Set shp = Sh.Shapes(Nm)
　shp.Delete
　On Error GoTo 0

　If Wi > 0 Then
　　Set shp = Sh.Shapes.AddShape(msoShapeRectangle, Bx, By, Wi, Hi)
　　shp.Name = Nm
　　shp.Fill.ForeColor.RGB = Cr
　　shp.Line.Visible = True　'外枠の有無
　End If

End Sub

お礼

ありがとうございます。
時間表示の所は、想定以上にわかりやすい構成でした。
これでばっちりです。

補足

コードありがとうございます。

1点教えていただきたい内容があります。

データベースからデータを持ってきた時、実績終了日時が空欄の場合があります。

この状態だと、
'//帯図形全数描写-----------------------------
Sub MakeBeltMain()
の
Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 5).Value - _
DSht.Cells(SCnt * SC + KCnt + 1, 4).Value) * WperHi
の部分で型が一致しません
のエラーになります。
終了日時が入っていないのでWiが負の値になってエラーになるのはわかるのですが、いったんこの空欄の日時を埋めて実行するとエラー発生しなくなり、再度同じセルを削除して空欄にしてマクロ実行した場合は、エラー発生しなくなります。
つまり、
イニシャル時にマクロ実行で、実績終了日時が空欄だとエラー。
一度実績終了日時を埋めた後で、マクロ実行してセルの内容を削除した場合はエラーが発生しなくなります。

実績終了が空欄の日時は、現在日時で書き込むので、ガント表示には支障ないのですが、上記エラー発生の有無を教えていただけないでしょうか。

回答No.6

HohoPapa

ごめんなさい、＃５で私が示したコードの場合
実績終了日時が空欄の場合に、計画側も描写しないコードでした。
3620313さんの示したコードでいいと思います。

お礼

ありがとうございます。
教えていただいたマクロを展開して運用させていただいています。
また、いきづまったらよろしくお願いします。

補足

いろいろとありがとうございます。
とても助かりました(^^)/

回答No.5

HohoPapa

いいと思います。なお、私だったら、
無駄にコードを走らせないために

'//帯図形全数描写-----------------------------
Sub MakeBeltMain()

　Dim SCnt As Long 'シリーズカウンター
　Dim KCnt As Long '工程カウンター
　Dim BPos As Double '左軸位置
　Dim Nm As String　　'図形名
　Dim Bx As Double　　'開始横位置
　Dim By As Double　　'開始縦位置
　Dim Hi As Double　　'高さ
　Dim Wi As Double　　'幅
　Dim Cr As Long　　'色
　Dim WperHi As Long　 '1日当たりの表示幅
　Dim TateHosei As Long
　Dim i As Long

　Hi = GSht.Rows(4).RowHeight * BeltHHi
　BPos = GSht.Cells(2, 4).Left
　WperHi = GSht.Cells(4, 8).Left - GSht.Cells(4, 4).Left
　TateHosei = GSht.Rows(4).RowHeight * ((1 - BeltHHi) / 2)
　Hi = GSht.Rows(4).RowHeight * BeltHHi
　BDay = Int(BDay)
　EDay = Int(EDay)

　SCnt = 0
　Do
　　If DSht.Cells(SCnt * SC + 1, 1).Value = "" Then Exit Do

　　GSht.Rows((SCnt * GC) + 3).ClearContents
　　For i = 0 To EDay - BDay
　　　GSht.Cells((SCnt * GC) + 3, ((i + 1) * 4)).Value = BDay + i
　　Next i

　　For KCnt = 1 To 6
　　　If DSht.Cells(SCnt * SC + KCnt + 1, 4).Value <> "" Then
　　　　Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "P"
　　　　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 2).Value - BDay) * WperHi)
　　　　By = GSht.Cells(SCnt * GC + (KCnt * 2) + 2, 1).Top + TateHosei
　　　　Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 3).Value - _
　　　　　　 DSht.Cells(SCnt * SC + KCnt + 1, 2).Value) * WperHi
　　　　Cr = rgbTurquoise　'計画のベルトの色
　　　　MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr

　　　　Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "J"
　　　　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 4).Value - BDay) * WperHi)
　　　　By = GSht.Cells(SCnt * GC + (KCnt * 2) + 3, 1).Top + TateHosei
　　　　Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 5).Value - _
　　　　　　 DSht.Cells(SCnt * SC + KCnt + 1, 4).Value) * WperHi
　　　　Cr = rgbGreenYellow　'実績のベルトの色
　　　　MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr
　　　End If
　　Next KCnt
　　SCnt = SCnt + 1
　Loop

End Sub

繰り返しますが、当方ではエラーにならないので、
後学のため、お使いのOffice（エクセルの）バージョンを教えてください。

回答No.4

HohoPapa

>終了日時が入っていないのでWiが負の値になってエラーになるのはわかるのですが
計画、実績とも、
開始日時が埋まり、終了日時が空欄の場合であっても
エラーにならないように作成しています。（作成しているつもりです。）
少なくとも当方の環境ではエラーになりません。

おそらく、
終了日時のセルは空欄ではなく、何か見えない文字（制御文字かも）が埋まっています。
=Code(セル番地)といった関数で中身を調べてみてください。

埋まっているものが何者なのかがわかれば、
その場合にはスルーするようにコードを修正します。

>実績終了が空欄の日時は、現在日時で書き込むので
開始日時が埋まり、終了日時が空欄、あるいは上記の未詳な文字が埋まっていたら
実行日時に読み替えるようにコードを修正したいですか？

補足

お手数おかけして申し訳ないです。

=Code(セル番地)で確認したら、空欄セルが全て＃VALUE！となります。
日時が入っている部分は52でした。

開始日時があって終了日時がない所は、=now()
でOKですが、
開始日時が空欄の部分で下記部分がエラーとなりました。

'//帯図形全数描写-----------------------------
Sub MakeBeltMain()

　　　Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "J"
　　　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 4).Value - BDay) * WperHi)

上記　Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 4).Value - BDay) * WperHi)
の部分でエラー

なのでD列のセルが空欄だったら何もしないの意味で

'//帯図形全数描写-----------------------------
Sub MakeBeltMain()

Dim SCnt As Long 'シリーズカウンター
Dim KCnt As Long '工程カウンター
Dim BPos As Double '左軸位置
Dim Nm As String '図形名
Dim Bx As Double '開始横位置
Dim By As Double '開始縦位置
Dim Hi As Double '高さ
Dim Wi As Double '幅
Dim Cr As Long '色
Dim WperHi As Long '1日当たりの表示幅
Dim TateHosei As Long
Dim i As Long

Hi = GSht.Rows(4).RowHeight * BeltHHi
BPos = GSht.Cells(2, 4).Left
WperHi = GSht.Cells(4, 8).Left - GSht.Cells(4, 4).Left
TateHosei = GSht.Rows(4).RowHeight * ((1 - BeltHHi) / 2)
Hi = GSht.Rows(4).RowHeight * BeltHHi
BDay = Int(BDay)
EDay = Int(EDay)

SCnt = 0
Do
If DSht.Cells(SCnt * SC + 1, 1).Value = "" Then Exit Do

GSht.Rows((SCnt * GC) + 3).ClearContents
For i = 0 To EDay - BDay
GSht.Cells((SCnt * GC) + 3, ((i + 1) * 4)).Value = BDay + i
Next i

For KCnt = 1 To 6
Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "P"
Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 2).Value - BDay) * WperHi)
By = GSht.Cells(SCnt * GC + (KCnt * 2) + 2, 1).Top + TateHosei
Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 3).Value - _
DSht.Cells(SCnt * SC + KCnt + 1, 2).Value) * WperHi
Cr = rgbTurquoise '計画のベルトの色
MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr

Nm = "Belt" & Format(SCnt, "000") & Format(KCnt, "00") & "J"

If DSht.Cells(SCnt * SC + KCnt + 1, 4).Value = "" Then

Else

Bx = (BPos + (DSht.Cells(SCnt * SC + KCnt + 1, 4).Value - BDay) * WperHi)
By = GSht.Cells(SCnt * GC + (KCnt * 2) + 3, 1).Top + TateHosei
Wi = (DSht.Cells(SCnt * SC + KCnt + 1, 5).Value - _
DSht.Cells(SCnt * SC + KCnt + 1, 4).Value) * WperHi
Cr = rgbGreenYellow '実績のベルトの色
MakeBelt GSht, Nm, Bx, By, Hi, Wi, Cr

End If

Next KCnt
SCnt = SCnt + 1
Loop

End Sub

としたら、エラーなく表示できたのですが、
こんな感じで大丈夫でしょうか？
確認までです。

回答No.2

HohoPapa

私の本業に追われ、マクロのコーディングをこれから始めます。

>軸書式の説明してませんでしたが、
>軸の最小値：計画開始日時と実績開始日時の全レコードの最小値
>軸の最大値：計画終了日時と実績終了日時の全レコードの最大値
>とするつもりです。

これは、
計画開始日時>計画終了日時
あるいは、
実績開始日時>実績終了日時　が想定されるという意味ですか？

また、serial1,2,3と増えていくわけですが、
軸の最小値、最大値は、serialごとに求めるんですか？
それとも、
serial1,2,3..これら全体で求めるんですか？

補足

これは、
計画開始日時>計画終了日時
あるいは、
実績開始日時>実績終了日時　が想定されるという意味ですか？
→
違います
通常であれば
実績開始日時＞計画開始日時
または
実績終了日時>計画終了日時
なのですが、
計画開始日時＞実績開始日時
または
計画終了日時>実績終了日時
の場合があるので、軸の最小値を計画、実績両方の最小値にする意味合いです。

serial1,2,3と増えていくわけですが、
軸の最小値、最大値は、serialごとに求めるんですか？
それとも、
serial1,2,3..これら全体で求めるんですか？
→
serial1,2,3..これら全体で求めるとします
の方です。
全シリアルの状況を日時で比較したいので、軸の最小、最大は、全アイテムとしています。

回答No.1

HohoPapa

次のように理解しました。
エクセルの積み上げ横棒グラフを利用してガントチャートを手作りしている。
手間がかかるので、VBAを使い、省力化したい。

エクセルの積み上げ横棒グラフを利用すると、
指摘の
>GANTグラフには工程間に細く青い線をしきりで入れてます。
の作業を追加したくなりますが

この線をグラフ上にVBAで線を引くのは
引く場所を特定するのが相当厳しいものになりましょう。

私だったら、
VBAを持ち込むわけですから、
添付画像のように、
グラフを使わず、シート上に図形を描写する対応にします。
これなら、補助線などを設ける作業は罫線ですから扱いやすいです。

これでよければ、
サンプルなコードを紹介できると思います。
（タイムリーには提示できませんが）

なお、series1,2,3..と増えていくものと思いますが
それごとにガントチャートのシートを分けるのではなく
1枚のシートに縦方向に並べるんですね？

更に、ざっくりでいいですので、
series1,2,3..と増えていく最大値を教えてください。

補足

グラフを使わず、シート上に図形を描写する対応にします。
これなら、補助線などを設ける作業は罫線ですから扱いやすいです。

これでよければ、
サンプルなコードを紹介できると思います。
→
図形描写で大丈夫です。

なお、series1,2,3..と増えていくものと思いますが
それごとにガントチャートのシートを分けるのではなく
1枚のシートに縦方向に並べるんですね？
→
1枚の縦方向に並べます

※
軸書式の説明してませんでしたが、
軸の最小値：計画開始日時と実績開始日時の全レコードの最小値
軸の最大値：計画終了日時と実績終了日時の全レコードの最大値
とするつもりです。

更に、ざっくりでいいですので、
series1,2,3..と増えていく最大値を教えてください。
→
ざっくり100レコードくらいあります。