[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『１日の作業工程をガントチャート表示にしたい-2』（yuri）
改めて新スレッドとして立ち上げました。
以前、[[20130926204446]]
元データはsheet4に入れました。
sheetの作りは
C D G H I K M O
4 到着便名 出発便名 到着時刻 出発時刻 担当グループ名 作業開始時間 終了時間 表示
5 AAA便 BBB便 06:30 08:30 田中 06:40 07:40 上 6 CCC便 DDD便 06:30 08:30 佐藤 06:40 07:40 上 7 EEE便 FFF便 06:30 08:30 吉田 06:40 07:40 上 8 GGG便 GGG便 06:30 08:30 田中 06:40 07:40 下
関数が入っているセル L列 =IF(E5="","",VLOOKUP($E5,$AI$1:$AJ$201,2,FALSE)) M列 =IF($L5="","",$K5+$L5) (L列につきましては、便毎に作業時間が決まっており、その時間が表示されます）
・行は５〜140行となっております。 ・140行は、今後便数の増も考慮し、所々空欄を設けてあります。
このSheet4を前スレッドのSheet2のガントチャートとして表示させたく思います。 よろしくご教授をお願い致します。 (yuri)
本当は、もう少し現状あるコードの意味を解析していただき、理解されてからの仕様変更のほうが良いと 思いますが・・・・。
ご自身も感じておられるかと思いますが、このSheet4にあるデータの方がデータのレイアウトとして、 今までのSheet1に比べると非常に簡単ですよね！！
>所々空欄を設けてあります。
この空欄があるとのことですが、担当グループ名を基準にして、4つの時刻があれば、作図をすることとします。 逆に言えば、グループ名がなく又は、４つの時刻の内一つでも空欄ならば、作図はしないことにします。
このように仕様を決めてしまえば、一見すると、Sheet1を入力データとしていたものより、 コードが簡単になりそうに思えます。
到着便名のあるセルの列番号は 3 （Ｃ列） 出発便名のあるセルの列番号は 4 (Ｄ列) 到着時刻のあるセルの列番号は 7 (Ｇ列） 出発時刻のあるセルの列番号は 8 (Ｈ列） 作業時間開始時刻あるセルの列番号は 11 (Ｋ列） 作業時間終了時刻あるセルの列番号は 13 (Ｍ列） 作図の位置 15 (Ｏ列）
問題は、作図する行をどうするか？ です。
提示されたデータ例を見てみると・・・、
Sheet4の5行目の田中は、Sheet2の3行に作図（実際には Ｏ列作図位置により、3か4行） Sheet4の6行目の佐藤は、Sheet2の5行に作図 Sheet4の7行目の吉田は、Sheet2の7行に作図
そして再度出てくる Sheet4の8行目の田中は、Sheet2の3行（実際には4行目）に作図しなければならないところです。
つまり、同じ担当グループ名があるかないかを検索しなければなりませんね！！
これは、Dictionaryというオブジェクトを使うと出来そうなので今回、これを使います。
有名なオブジェクトですから、どんなことが出来るのか調べてみてください。
新規ブックの標準モジュールに
Sub test()
Dim dic As Dictionary
Dim testarray As Variant
Dim ans As Variant
Dim g0 As Long
testarray = Array("田中", "佐藤", "吉田", "田中", "上原", "佐藤")
Set dic = CreateObject("scripting.dictionary")
For g0 = LBound(testarray) To UBound(testarray)
If Not dic.Exists(testarray(g0)) Then
dic.Add testarray(g0), ""
End If
Next
For Each ans In dic.Keys
MsgBox ans
Next
Set dic = Nothing
End Sub
上の例は、"田中", "佐藤", "吉田", "田中", "上原", "佐藤" というデータから、重複なしのデータ（"田中", "佐藤", "吉田", "上原"） を作成する例です。
これを使えば何とかなりそうです。
その前に yuriさんには、この重複を考えないでガントチャートを 作成するコードを提示してみてください。
つまり、
Sheet4の5行目の田中は、Sheet2の3行に作図（実際には Ｏ列作図位置により、3か4行） Sheet4の6行目の佐藤は、Sheet2の5行に作図 Sheet4の7行目の吉田は、Sheet2の7行に作図 そして再度出てくる Sheet4の8行目の田中は、Sheet2の9行に作図（実際には作図位置（下）を考慮すると10行）
というコードです。これでは、なさりたい仕様とは違いますが、 これが自力で何とかなるかならないかが 大問題です。
今までのことが理解できていれば、これは作成できると思います。
上記のコードを提示してください。 （ichinose） 2013/11/11(月) 06:13
お世話になっています。そしてご教授ありがとうございます。
早速、上記コードを新規Bookの標準モジュールに入れて確認しました所、
dic As Dictionaryの所がコンパイルエラーと出ました。 私も、Dictionaryについて調べて勉強してみます。 (yuri)
失礼しました。
Dim dic As object
と、修正してください
（ichinose） 2013/11/11(月) 09:12
ご教示ありがとうございます。
作図に挑戦してみました。
5行目については作図が出来ましたが、6行目以降ができません。
エラーも「形が一致しません」と出ます。
コードは下記のようになっています。
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "a").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5
rw = 4
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value
col = 3
Do Until col > 15
If col <= 18 Then mkrw = rw Else mkrw = rw + 1
If sht.Cells(idx, col).Value <> "" Then If sht.Cells(idx + 1, col + 1).Value <> "" Then Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 4).Value, sht.Cells(idx, col + 1).Value, _
sht.Cells(idx, col + 5).Value, sht.Cells(idx, col + 8).Value, sht.Cells(idx, col + 10).Value, hh, carray((rw - 4) / 2 Mod 5))
col = col + 1
Loop
idx = idx + 2
rw = rw + 2
Loop
End Sub
(yuri)2013/11/13 18:03
Sheet1のデータとデータのあるセル番地と既に出来上がっているコードをよくみてください。 よく見るというのは、コードにコメントをご自分で付けていくのです。
以下のコードは、前スレッドでyuriさんが投稿されたコードです。
>「色」出来ました。 見てください。
>Sub main2()
> Const ss = 2
> Dim hh As Single
> Dim idx As Long
> Dim rw As Long
> Dim row1 As Long
> Dim mkrw As Long
> Dim col As Long
> Dim carray As Variant
> Dim sumwidth As Single
> Dim sht As Worksheet
> Set sht = Worksheets("sheet1")
> With sht
> row1 = .Cells(.Rows.Count, "a").End(xlUp).Row
> End With
> With Worksheets("sheet2")
> On Error Resume Next
> .DrawingObjects.Delete
> On Error GoTo 0
> For idx = 1 To ss - 1
> sumwidth = sumwidth + .Columns(idx).ColumnWidth
> Next
> hh = .Range("b:b").ColumnWidth
> End With
> Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
> carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
> idx = 11
> rw = 3
> Do Until idx > row1
> Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
> col = 2
> Do Until col > 38
> If col <= 18 Then mkrw = rw Else mkrw = rw + 1
> Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 1).Value, sht.Cells(idx, col + 2).Value, _
> sht.Cells(idx, col + 3).Value, sht.Cells(idx + 1, col + 2).Value, sht.Cells(idx + 1, col + 3).Value, hh, carray((rw - 3) / 2 Mod 5))
> col = col + 4
> Loop
> idx = idx + 2
> rw = rw + 2
> Loop
>End Sub
これに意味が分かるようにコメントを付けてみるのです。 良い勉強になります。 例えば
> idx = 11 'Sheet1のデータ読み込み開始行をidxに設定
> rw = 3 'Sheet2の作図開始行 rwに設定
> Do Until idx > row1 'Sheet1のデータ読込み行が最終行を超えるまでループ
> Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
’↑Sheet2にグループ名を設定
> col = 2 'Sheet1のデータの読み込み開始列番号を設定
> Do Until col > 38 ' 開始列番号が38を超えるまでループ「10回目まで読み込む）
> If col <= 18 Then mkrw = rw Else mkrw = rw + 1
'↑列番号により、作図行を調整
> Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 1).Value, sht.Cells(idx, col + 2).Value, _
> sht.Cells(idx, col + 3).Value, sht.Cells(idx + 1, col + 2).Value, sht.Cells(idx + 1, col + 3).Value, hh, carray((rw - 3) / 2 Mod 5))
'↑作図
> col = col + 4 'Sheet1のデータ読み込み開始列を4つ増やす
> Loop
> idx = idx + 2 'Sheet1のデータ読み込み行を二つ増やす
> rw = rw + 2 'Sheet2の作図行二つ増やす
> Loop
こんな感じです。 で今回投稿されたコードに戻ると・・・、
idx = 5
rw = 4
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value
col = 3
Do Until col > 15
If col <= 18 Then mkrw = rw Else mkrw = rw + 1
If sht.Cells(idx, col).Value <> "" Then If sht.Cells(idx + 1, col + 1).Value <> "" Then Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 4).Value, sht.Cells(idx, col + 1).Value, _
sht.Cells(idx, col + 5).Value, sht.Cells(idx, col + 8).Value, sht.Cells(idx, col + 10).Value, hh, carray((rw - 4) / 2 Mod 5))
col = col + 1
Loop
idx = idx + 2
rw = rw + 2
Loop
ループコード（Do〜Loop）の中にもう一つループコードがありますよね？
idx = 5
rw = 4
Do Until idx > row1
・
col=3
Do Until col > 15
・
・
Loop
idx = idx + 2
rw = rw + 2
Loop
Sheet1のデータが1行の中に作図すべきデータが10個あったからですよね？ だから、列番号をデータのある列の規則を調べて（4つおきにデータがある） ループコードを作成したのです。
今回のSheet4のデータは、1行のデータで一つの作図ですよね？
よって、中のループは要らないはずです。
プログラムは、入力データや出力データによって構造が大きく変わってしまいす。
もう一度既に作動している Sheet1のデータからShhet2に作図のコードを 見てプログラムを理解してください。
エラーの原因は、Sheet4には、作図するべきデータは、1行に一つしかないのに プログラムは、未だに10個あると思って 作図しようとしているからです。
これで再考してください
（ichinose） 2013/11/14(木) 04:54
お世話になります。
まだ、作図は1行目のみ、グループ名は2行のみ表示されます。
いまのコードです。
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
col = 3 'sheet4のデータの読み込み開始「列」番号を設定
If col <= 18 Then mkrw = rw Else mkrw = rw + 1 '列番号により、作図行を調整
If sht.Cells(idx, col).Value <> "" Then If sht.Cells(idx + 1, col + 1).Value <> "" Then Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 4).Value, sht.Cells(idx, col + 1).Value, _
sht.Cells(idx, col + 5).Value, sht.Cells(idx, col + 8).Value, sht.Cells(idx, col + 10).Value, hh, carray((rw - 4) / 2 Mod 5)) '作図
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
あとは、どこを変えれば？？
教えて下さい。
(yuri)2013/11/14 23:30
まだ、プログラムには、Sheet1のデータだと思っている箇所がいくつかあります。
Sub 新ガントチャート()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Set sht = Worksheets("sheet4")
'************************************************************問題１
With sht
row1 = .Cells(.Rows.Count, "a").End(xlUp).Row
End With
'************************************************************
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
'*********************************************************************問題２
col = 3 'sheet4のデータの読み込み開始「列」番号を設定
If col <= 18 Then mkrw = rw Else mkrw = rw + 1 '列番号により、作図行を調整
If sht.Cells(idx, col).Value <> "" Then If sht.Cells(idx + 1, col + 1).Value <> "" Then Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 4).Value, sht.Cells(idx, col + 1).Value, _
sht.Cells(idx, col + 5).Value, sht.Cells(idx, col + 8).Value, sht.Cells(idx, col + 10).Value, hh, carray((rw - 4) / 2 Mod 5)) '作図
'*********************************************************************
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
問題１
With sht
row1 = .Cells(.Rows.Count, "a").End(xlUp).Row
End With
これ、そもそも何をしているのでしょうか？
この処理で 変数row1には、どんな値が設定されているのでしょうか？
Sheet1では、A列は、グループ名がありましたね？ Sheet4では、A列が規定されていませんね！！
>Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ とあるように データがある最終行をrow1に設定されているのです。
が、A列基準にしてデータのある最終行が正しく求められていますか？
それから、 .Cells(.Rows.Count, "a").End(xlUp) ←これ
何をしているのか調べてみてください。
Ａ 1 あああ 2 いいい 3 ううう 4 ええ 5 お
sub 実験()
with activesheet
.cells(.rows.count,"a").end(xlup).select
end with
end sub
実験を実行してください A5を選択しますよね
データを増やしたり、減らしたりして試してください。
これは、A列最終行 A1048576の選択した状態で ctrl+↑ キーを押した状態と同じなんです。
これでデータ範囲をプログラムは把握します。
今回、グループ名の列をデータ範囲を把握する基準列にしたのです。 これは、Sheet4でも同じにすると・・・、 グループ名は Sheet4では、A列ではないですね！！
調べてみてください。
問題２
col = 3 Sheet1の場合、1行に10個の作図データあるということでしたので、 ループさせる基準の列を変数colに格納し、ループ内でこのcolに一定の値を足していって、すべてのデータを作図させようとしたのですよね！！ Sheet4では、1行に一つのデータの作図なのでcolという変数も必要ないですね！！ 直接、
Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, 3).Value, sht.Cells(idx, 7).Value, sht.Cells(idx, 4).Value,・・・・・）
等と指定すればよいですよね？
If col <= 18 Then mkrw = rw Else mkrw = rw + 1
↑これは、何をしているのですか？
Sheet1では、6個目以降の作図は、1行下に作図するのでしたね？
よって、colの列番号によって、作図する行を調整していたのですが、 Sheet4では、どのデータで作図する行の調整をするのですか？ 考えてください。
If sht.Cells(idx, col).Value <> "" Then If sht.Cells(idx + 1, col + 1).Value <> "" Then colの値を3とした場合、
sht.Cells(idx, 3).Value
sht.Cells(idx + 1, 4).Value
Sheet4の 列番号3は、到着便名 列番号4は、出発便名、しかもこれは、idx+1ですから、1行下です。
これらのデータが未入力でなかったら、作図するのですが、
こんな条件でよいのですか？
Sheet4では、1行で一つのグループのデータを表現しているのですから 1行下だと別のグループのデータを見ていることになってしまいます。
Sheet1とSheet4のデータと位置とコードの意味を一行一行理解しながら、 Sheet4のデータに沿ったコードを作成してください。
（ichinose） 2013/11/15(金) 07:11
詳しく、そして細かく説明して頂き本当に有難うございます。
そして、私なりに勉強しました。
先ず、問題1です。
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row 'sheet4のグループ名を上方向に最終行まで取得
このように変更しました。(実験）を試してみて、分かりました。
次に問題2です。
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 15).Value = "上" Then mkrw = rw Else mkrw = rw + 1 'sheet2の作図位置をsheet4の「上」の表示で決める
Call 作図(Worksheets("sheet2"), mkrw, sht.Cells(idx, 3).Value, sht.Cells(idx, 7).Value, sht.Cells(idx, 4).Value, _
sht.Cells(idx, 8).Value, sht.Cells(idx, 11).Value, sht.Cells(idx, 13).Value, hh, carray((rw - 4) / 2 Mod 5)) '作図
このように変更しました。
これで、とりあえずグループ名も作図も全グループ表示されます。
よくわからないのは、
If sht.Cells(idx, 15).Value = "上" Then mkrw = rw Else mkrw = rw + 1 これです。と言うのは、基本は全て下段に作図され"上"と入力されれば、上に作図されます。これを逆にしたいのですが？基本は上に作図、"下"とあれば下段に作図です。
又、Call 作図(Worksheets("sheet2"), ・・・の文に形が一致しませんと出ます。
>これらのデータが未入力でなかったら、作図するのですが、こんな条件でよいのです か？
sheet4のデータでは、到着するだけで、その日出発しない便もあります。その場合の作図は、最後の時間まで伸びるので、何か良い方法が無いものか考えた結果、作業自体は発生するので、可能であれば出発便が空欄の場合は作業開始と終了時間で作図がされればと思います。他に何か良い方法があればアドバイス下さい。
(yuri)2013/11/15 20:30
>よくわからないのは、 > If sht.Cells(idx, 15).Value = "上" Then mkrw = rw Else mkrw = rw + 1 >これです。と言うのは、基本は全て下段に作図され"上"と入力されれば、上に作図されます。これを逆にした >いのですが？基本は上に作図、"下"とあれば下段に作図です。
前のスレッドで
>>If文もいくつかのパターンがありますから、よく調べてみてください。 >>全部のパターンがかなりの頻度で使われていますよ。
と申し上げたのですが、覚えていますか？
If 条件 Then 条件が真のときの処理 Else 条件が偽のときの処理
If sht.Cells(idx, 15).Value = "上" Then mkrw = rw Else mkrw = rw + 1 ↑O列のセルが 「上」 という文字列であれば、上の行をmkrwに設定 そうでなければ、下の行（rw+1）をmkrwに設定
という意味です。つまり、O列のセルの中身が、「上」 という文字列か そうでないかで処理を分岐しています。 O列のセルが未入力の場合、「上」という文字列ではないので mkrwに下の行が設定されるのです よね？
今度は 「下」という文字列であるかないかでIf文を構築してみてください。
>sheet4のデータでは、到着するだけで、その日出発しない便もあります。 >その場合の作図は、最後の時間まで伸びるので、何か良い方法が無いものか考えた結果、 >作業自体は発生するので、可能であれば出発便が空欄の場合は作業開始と終了時間で作図がされればと思います。
そうなると、作図 というプロシジャーの変更が必要ですねえ！！
仕様をこのようにしましょうか？
作図に辺り、必須項目
到着便名 到着時刻 出発時刻 作業開始時刻 作業終了時刻
上記が未入力の場合は、Call 作図（・・・）を実行しない
出発便名が 未入力の場合、
出発時刻には、作業終了時刻を指定する
こんな仕様にしてみては いかがですか？
例 到着便名 aaa 出発便名 未入力 到着時刻 15:00 出発時刻 未入力 作業開始時刻 15:30 作業終了時刻 17:15
このような場合、
到着時刻 15:00〜 作業終了時刻 17:15 で四角形を作成 作業開始時刻 15:30〜 作業終了時刻 17:15 で矢印図形を作成
という仕様になります。
この場合、プロシジャー作図の変更も必要ですが、 作図に送るパラメータデータの決定も Sheet4データで判断して決めなければなりません。
この様な仕様でいかがですか？
作図時にコメント（四角形に表示する文字列）も変えなければなりませんね！！
通常は、 AAA便 到着 : 06:30／BBB便 出発 : 08:30
↑このような内容ですが、出発便がない場合は、どうしますか？
これが分かれば、プロシジャー作図の変更は、私が受け持ちます。
考えてみてください
（ichinose） 2013/11/16(土) 08:28
おはようございます。早朝からご教示ありがとうございます。
>>>If文もいくつかのパターンがありますから、よく調べてみてください。 >>全部のパターンがかなりの頻度で使われていますよ。 ・了解しました。調べて勉強します。
出発便が無い場合ですが、ichinose様の提案でよいです。
出発便が無い場合の作業は、午前中に到着しても出発が無いから作業自体は夜になったりしますので。それに対応が出来れば、OKです。
四角の図表示ですが、出発便名、時間が未入力の場合は、「***」とかになりますか？
何も、表示されなくても構いませんが・・・
よろしくお願いいたします。
(yuri)2013/11/16/ 9:16
新しい作図です（作図2とします）
'=========================================================================
Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
, ByVal 到着時刻 As Date _
, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date _
, ByVal 作業終了時刻 As Date _
, ByVal hh As Single _
, Optional ByVal Reccolor As Long = vbRed)
Dim st As Single
Dim wk As Double
Dim shp As Shape
wk = (出発時刻 - 到着時刻) / TimeSerial(0, 10, 0)
st = (到着時刻 - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_shape(シート.Rows(作成行), st, wk * hh, msoShapeRectangle, シート)
With shp
.TextFrame.Characters.Text = 表示文字列
.TextFrame.Characters.Font.Color = vbBlack
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.Fill.ForeColor.RGB = Reccolor
.Fill.Transparency = 0.5
End With
wk = (作業終了時刻 - 作業開始時刻) / TimeSerial(0, 10, 0)
st = (作業開始時刻 - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_line(シート.Rows(作成行), st, wk * hh, 80, シート)
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
End Sub
違いは、四角形に表示する文字列は、呼び出し側で編集することとします。
前回のyuriさんのコードをで今までどおりに作動させるには、
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 15).Value = "上" Then mkrw = rw Else mkrw = rw + 1 'sheet2の作図位置をsheet4の「上」の表示で決める
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
'表示する文字列を編集
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5)) '作図
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
大きな違いは、到着便名と出発便名というデータを作図に送るのを止めました。 代わりに四角形に表示する文字列を送るにしました。
後は、
>作図に辺り、必須項目 >到着便名 >到着時刻 >出発時刻 >作業開始時刻 >作業終了時刻 >上記が未入力の場合は、Call 作図（・・・）を実行しない >出発便名が 未入力の場合、 >出発時刻には、作業終了時刻を指定する
データの有無のチェックと出発便名が未入力の場合の作図2に送る表示文字列の編集が必要になります。
これは、考えてみてください。
（ichinose） 2013/11/16(土) 14:22
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
もしかしてこれは・・・
>データの有無のチェックと出発便名が未入力の場合の作図2に送る表示文字列の編集が必要になります。
これは、考えてみてください。
と言うことで編集が必要だから、出るのでしょうか？
すみません。理解不足で。もう少し詳しくお願いします。
(yuri)2013/11/17 8:55
> Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
>型が一致しません
作図2を実行する場合、到着時刻、出発時刻、作業開始時刻、作業終了時刻 これらのデータに必ず必要です（その他のパラメータもですが、特に列挙した時刻）。
つまり、これらのセルに時刻以外の入力がある場合、そのまま実行すれば、型が一致しない というエラーがでます。
文字列の編集は、正しく編集しなければ、ただしく表示されないだけでエラーにはならないと思います。
再度確認しますが、
Ｇ列 到着時刻 Ｈ列 出発時刻
Ｋ列 作業開始時刻 Ｍ列 作業終了時刻
これらの列のうち、一つでも時刻がでないデータだと今のコードでは、 記述されたようなエラーが発生します。
入力データを再度確認してください
（ ichinose） 2013/11/17(日) 11:29
色々とお世話になります。
確認しました。
G,H,K,M列の間違いはありません。
時間の入力については、13:45と入力している箇所と1345と入力している箇所があったので、13:45としました。
後は、sheet4の作りについてですが、上は5行目から下は125行目まで隙間なく入力されているわけではありません。
行先方面が3つ位あるので、その方面と方面の間は10行空けています。
作図されたsheet2を確認しましたが、5行目から38行目までは空欄行が無いので、作図されていますが、39行が空欄なのでそれ以降の図が出来ていません。
原因はこれでしょうか？
(yuri)2013/11/17 17:54
>今度は 「下」という文字列であるかないかでIf文を構築してみてください。 ここの部分は出来ました。
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw このようになりました。 (yuri)
>後は、sheet4の作りについてですが、上は5行目から下は125行目まで隙間なく入力されているわけではありません。
現状のコードは、最低でも グループ名と4つの時刻は、入力されている とプログラムは、想定して 処理をしています。
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
現状コードを見てください。Sheet2の最終行を超えるまでは、何の制御もなく、 上記の 作図2を呼び出していますよね？
Sheet2のデータを見て、必須データが入力されていなければ、作図はしない という処理をコードに入れなければならないのです。
その条件として、
>作図に辺り、必須項目 >到着便名 >到着時刻 >出発時刻 >作業開始時刻 >作業終了時刻 >上記が未入力の場合は、Call 作図（・・・）を実行しない >出発便名が 未入力の場合、 >出発時刻には、作業終了時刻を指定する
↑この内容をコードにいれなければなりません。
更に付け足しで
グループ名も未入力だったら、作図はしない という条件も入れましょうか！！
整理すると
作図に辺り、必須項目 グループ名 到着便名 到着時刻 出発時刻 作業開始時刻 作業終了時刻 上記が未入力の場合は、Call 作図2（・・・）を実行しない
出発便名が 未入力の場合、 出発時刻には、作業終了時刻を指定する 又、四角形に入れる文字列は、条件によって、編集する
上記の内容をyuriさんが考えてコード化するのですよ！！
グル-プ名のセットや作図2を呼び出す前に 作図に必要なデータの有無や条件によって、 四角形に表示する文字列を編集する処理を付け加えるということです。
ここで使うのが、If文です。
今度は、IF文の別の書式を使ったほうが良いでしょうね
If 条件 then
条件が真の時の処理
else
条件が偽の時の処理
end if
このIf文は、条件が真、偽の処理を複数行のコードが記述できることです。
>時間の入力については、13:45と入力している箇所と1345と入力している箇所 本当は、こういう入力ミスも想定して作図しない処理が必要なんです。 今回の作図範囲は、5：00から24：00までですよね！！
これは、次回の課題としましょう。
以上です。作図するか否か、文字列編集を条件によってどのようにすればよいか？
考えてみてください。
（ ichinose） 2013/11/18(月) 06:56
>If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw >このようになりました。
これですね！！
（ ichinose） 2013/11/18(月) 07:09
ご教示ありがとうございます。
今、どうやってコード化するか、If文例を検索しながら勉強しています。
>グル-プ名のセットや作図2を呼び出す前に 作図に必要なデータの有無や条件によって、 四角形に表示する文字列を編集する処理を付け加えるということです。
とありますが、コードを入れる場所は、
> Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value
の前にコードを入れる事でしょうか？
コードは勉強中ですが、
If sht.Cells(idx, 7).Value"" Then If sht.Cells(idx, 8).Value""Then・・・ 等にしてセルが空欄であれば、の処理とElueの処理をどうコード化するのか わかりません。（作図を実行しない と作る方法です）
またまた、ご教授お願いします。
(yuri) 2013/11/18 22:39
> > Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value
>の前にコードを入れる事でしょうか
でしょうねえ、グループ名を設定してから、チェックするより、設定する前にチェックする方が 一手間処理が減りそうですからねえ。
>セルが空欄であれば、の処理とElueの処理をどうコード化 Elue ----＞ Else ですよ！！
前のスレッドで
If sht.Cells(idx, col).Value <> "" And sht.Cells(idx + 1, col + 2).Value <> "" Then
Call 作図(Worksheets("SKD表"), mkrw, sht.Cells(idx, col).Value, sht.Cells(idx, col + 1).Value, sht.Cells(idx, col + 2).Value, _
sht.Cells(idx, col + 3).Value, sht.Cells(idx + 1, col + 2).Value, sht.Cells(idx + 1, col + 3).Value, hh, carray((rw - 3) / 2 Mod 5))
End If
上記のコードをご紹介しましたが、見て頂いていますよね？
これまでのやりとりは、Sheet1のデータからSheet2の作図と考え方は、同じです。 ただ、データの位置や作図の条件がちょっと違うだけです。 まだ、冒頭で記述した Dictionaryは、出てきていません。
今、やられていることは、復習です。
時刻に関しては、実は、Cells(Idx,7).value<>"" だけでは、不十分ですが、今回は、これでよいことにします。
作図する条件をもう一度よく見直して、コードを提示してください
（ ichinose） 2013/11/19(火) 06:46
お世話になります。
以前スレッドのコードを見直して、sheet4に合わせたコードに変更していますが、うまく行きません。
コードはこのようになっています。
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 8).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then _
Call 作図2(Worksheets("sheet2"), mkrw, sht.Cells(idx, 7).Value, sht.Cells(idx, 8).Value, sht.Cells(idx, 9).Value, sht.Cells(idx, 11).Value, sht.Cells(idx, 13).Value, hh, carray((rw - 4) / 2 Mod 5)) _
Else sht.Cells(idx, 4).Value "" = sht.Cells(idx, 8).Value = sht.Cells(idx, 13).Value
>出発便名が 未入力の場合、 出発時刻には、作業終了時刻を指定する 又、四角形に入れる文字列は、条件によって、編集する
特に、この処理がわかりません。どうすれば？？
「引数が一致しません。・・・」と出ます。
すみません。教えて下さい。
(yuri)
今回は、
>If 条件 then > 条件が真の時の処理 >else > 条件が偽の時の処理 >end if
前々回に投稿したように上記の書式のIf文を使うのですよ！！
ですから、If文を調べてください と申し上げたのです。
>If文もいくつかのパターンがありますから、よく調べてみてください。 >全部のパターンがかなりの頻度で使われていますよ。
ということも記述しました。
きちんと調べましたか？ これが勉強でしょう？
>「引数が一致しません。・・・」 「引数の型が一致しません。」ではないですか？ こういう記述は正確に記述してください。
作図2というプロシジャーに送るデータが何なのか？ よく見直してください。
Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
, ByVal 到着時刻 As Date _
, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date _
, ByVal 作業終了時刻 As Date _
, ByVal hh As Single _
, Optional ByVal Reccolor As Long = vbRed)
最初が 作図するシートオブジェクト −−− シート
作成する行 −−− 作成行
四角形に表示する文字列 −−− 表示文字列
到着時刻
出発時刻
作業開始時刻
作業終了時刻
hh −−− 作図シートの時間を表すセルのセル幅
Reccolor −−− 四角形の塗りつぶしの色（RGB）
引数は、上記の9個のデータをこの順序で指定しなくては、なりません。
提示されたコードをよく見てください。
Call 作図2(Worksheets("sheet2"), mkrw, sht.Cells(idx, 7).Value, sht.Cells(idx, 8).Value, sht.Cells(idx, 9).Value, sht.Cells(idx, 11).Value, sht.Cells(idx, 13).Value, hh, carray((rw - 4) / 2 Mod 5))
sht.Cells(idx, 9).Valueを指定した位置には、本来、出発時刻が指定されなければなりませんが、 これは、グループ名でしょう？
時刻のデータが指定されなければ、 引数の型が一致しません となります。
それからちょっと訂正
>作図に辺り、必須項目 >到着便名 >到着時刻 >作業開始時刻 >作業終了時刻 >上記が未入力の場合は、Call 作図（・・・）を実行しない >出発便名が 未入力の場合、 >出発時刻には、作業終了時刻を指定する
出発時刻は、必須入力項目から除外します。
まず、必須項目が入力されているか否かのチェックについては？
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then
これでよいです。
これらのデータがあれば、とにかく作図はします。
Thenより下の行には作図する方向でコードを記述するのですが、
出発便名が記述された場合とされない場合で作図2に送るデータを変えなければなりません。
まず、四角形に表示する文字列は、
前の投稿で この文字列を入れる変数として、dstr を宣言しました。
dim dstr as string
もう一つ出発時刻という変数も宣言しましょう。
dim 出発時刻 as date
出発便名が入力されている場合は、
今までと同様の表示をしたいので
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発便名が入力されていない場合は、
ここをご自分でどのように表示させたいか？ 考えるのですよ！！私が決めることではないので・・・。
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
if sht.cells(idx,4).value<>"" then '出発便名が入力されていたら？
dstr=sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻= sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入
else
dstr="自分で表示を考えること"
出発時刻=sht.Cells(idx, 13).Value '作業終了時刻を代入
end if
call 作図2(・・・・) 'ここにどのように引数を指定すればよいか 考えてください
end if
このままコピーしたって作動しませんよ！！
自分で考えてください。
（ ichinose） 2013/11/20(水) 19:44
ご教示ありがとうございます。
もっと、色々と調べ勉強します。
(yuri)
ここ数日、調べながら勉強しております。
>このままコピーしたって作動しませんよ！！ どうしたら動くか、コードを変更しながらやっていますが、 どうしても下記エラーが出ます。そのエラーの意味が分かりません。 「アプリケーション定義またはオブジェクト定義のエラーです」と出て、 ここの部分が黄色になります。
> Set shp = mk_shape(シート.Rows(作成行), st, wk * hh, msoShapeRectangle, シート)
現在のコードです。
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '5項目が入力されている事をチェック
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm") '四角の作図
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & "*** : " & Format(sht.Cells(idx, 13).Value, "hh:mm") 'そうでなければ、この作図
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
度々すみません、お願いします。 (yuri) 2013/11/22 20:08
コードの提示をその箇所だけ提示されていますが、
Sub 新ガントチャート2() というプロシジャーを基にコード変更されているなら、そのプロシジャーのすべてのコードを 掲載してください。
それから、入力データ（Sheet4のデータ）については、yuriさんからは、このスレッドの最初でしか 提示されていません。
エラーが発生した場合、この入力データが原因だということはわかりますよね？
でしたら、エラーが発生したときの 入力データを提示してください
4 到着便名 出発便名 到着時刻 出発時刻 担当グループ名 作業開始時間 終了時間 表示 5 AAA便 BBB便 06:30 08:30 田中 06:40 07:40 上 6 CCC便 DDD便 06:30 08:30 佐藤 06:40 07:40 上 7 EEE便 FFF便 06:30 08:30 吉田 06:40 07:40 上 8 GGG便 GGG便 06:30 08:30 田中 06:40 07:40 下
エラー時の上記のデータの詳細です。
出発時刻という変数を設けて、出発便名が入力されている時といないときとで 設定する値を区別していますよね！！
なのにどこにも使われていません。どうしてですか？
これは、Call 作図2（・・・） の引数に使わなければ意味がありませんよ！！
プロシジャーのコードすべての提示とエラー時のデータの詳細を提示してください
（ ichinose） 2013/11/23(土) 04:44
申し訳ありません。
はいsheet4のデータです。
C D G H I K M O
4 到着便名 出発便名 到着時刻 出発時刻 担当グループ名 作業開始時間 終了時間 表示
5 AAA便 BBB便 06:30 08:30 田中 06:40 07:40 上 6 CCC便 DDD便 06:30 08:30 佐藤 06:40 07:40 上 7 EEE便 FFF便 06:30 08:30 吉田 06:40 07:40 上 8 GGG便 GGG便 06:30 08:30 田中 06:40 07:40 下 となって変更はありません。
そして、これが新ガントチャート2()です。
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '5項目が入力されている事をチェック
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm") '四角の作図
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & "*** : " & Format(sht.Cells(idx, 13).Value, "hh:mm") 'そうでなければ、この作図
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
, ByVal 到着時刻 As Date _
, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date _
, ByVal 作業終了時刻 As Date _
, ByVal hh As Single _
, Optional ByVal Reccolor As Long = vbRed)
Dim st As Single
Dim wk As Double
Dim shp As Shape
wk = (出発時刻 - 到着時刻) / TimeSerial(0, 10, 0)
st = (到着時刻 - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_shape(シート.Rows(作成行), st, wk * hh, msoShapeRectangle, シート)
With shp
.TextFrame.Characters.Text = 表示文字列
.TextFrame.Characters.Font.Color = vbBlack
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.Fill.ForeColor.RGB = Reccolor
.Fill.Transparency = 0.5
End With
wk = (作業終了時刻 - 作業開始時刻) / TimeSerial(0, 10, 0)
st = (作業開始時刻 - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_line(シート.Rows(作成行), st, wk * hh, 80, シート)
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
End Sub
と、このようになっています。
早朝からの、ご対応本当に有難うございます。
(yuri) 2013/11/23 8:35
ご自分でコードの流れとか意味を理解しながら、コードを作成しないといつまでもコードは書けませんよ！！
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
この作図2を呼び出すときには、指定する引数は、事前に設定されているはずですが、
mkrwは、呼び出す前に設定されていませんよね！！ この場合、mkrwには、0が設定されています。0では、作図2の中で記述されたようなエラーになります。 だって、シート行は、1からですから・・・。
確かに呼び出した後に
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
なんて記述されていますけど、これでは意味がありません。
それからその上の行の
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
これ、グループ名を設定ししている箇所ですよね！！
これは、
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then
この条件が真のときに設定するのです。
提示コードでは、それには関係なく設定しています。
それから何度も言っていますが、 出発時刻 という変数が使われていません。
これを使わなければ、
>出発便名が 未入力の場合、 >出発時刻には、作業終了時刻を指定する
この設定が完了しませんよ！！
再度、If文の使い方や提示したIf文の意味を理解してください。
（ ichinose） 2013/11/23(土) 17:01
お世話になっております。
ichinoseさんの言う通り、出発時刻の変数をどうやって使うのか、変数の使用例を探りながら試している所です。しかしながら思うように動いてくれません。
色々といじっていたら、先ほどまでは、作図はされていましたが、現在はグループ名のみ表示され、図が出なくなりました。
原因がわからずです。
今現在のコードです。
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
Else
sht.Cells(idx, 4).Value
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " ※※※ : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
まだまだ理解するのに時間が掛かりそうです。
エラーの内容は、
「アプリケーション定義またはオブジェクト定義エラーです」とでます。
アドバイスをお願いいたします。
(yuri)2013/11/27 11:42
If文の中や 繰り返し処理を行う一連の命令群を入れ子と呼ぶんですが、 この入れ子には インデント（字下げ）を付けるコーディングをしないと かなり慣れた方でもコードが読みにくいです。
まず、きちんと入れ子単位でインデントを付けたコードを提示するようにしてください。 コードが理解しづらい理由の一つかもしれませんよ！！
提示されたコードをインデントを付けてみると、
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
Else
sht.Cells(idx, 4).Value
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " ※※※ : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
Do Until ・・・
字下げを行ってコードを記述します。
aaaaa
bbbbbbb
loop
If文も同じです。
if a=1 then
if b=1 then
msgbox "○"
else
msgbox "▽"
end if
else
msgbox "×"
end if
最初にこのような癖を付けておいてください。
さて、コードの問題のLoop文の中を見てみましょう。
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
Else
sht.Cells(idx, 4).Value
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " ※※※ : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
必須項目のチェックを行い、この条件を通れば、作図するのですよね？
次に出発便名が入力されていたら、 文字列を変数dstrに設定し、 変数 出発時刻に出発時刻があるセルの値を設定
出発便名が設定されていないときは、
sht.Cells(idx, 4).Value 'これ何？ 意味不明 要らない
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " ※※※ : " & Format(sht.Cells(idx, "出発時刻").Value, "hh:mm")
'文字列の設定
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
'↑変数 出発時刻に 作業終了時刻を設定
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
'条件によって mkrwを設定
という処理を行っています。
これだと、作図する行を示す変数mkrwは、
「出発便名が設定されていないとき」だけしか値が設定されません。
エラーの原因はこれです。 作図は、必須項目が入力されていれば、必ずするのです。 だったら、出発便名の入力の有無にかかわらず、mkrwは、設定されなければなりません。
では、
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
↑この処理をどこに入れなければならないか？
よく考えてください。
（ichinose） 2013/11/27(水) 18:21
変数 出発時刻 について、
何のためにこのような変数を作ったと思いますか？
Sub 作図2(ByVal シート As Worksheet, ByVal 作成行 As Long, ByVal 表示文字列 As String _
, ByVal 到着時刻 As Date _
, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date _
, ByVal 作業終了時刻 As Date _
, ByVal hh As Single _
, Optional ByVal Reccolor As Long = vbRed)
最初が 作図するシートオブジェクト −−− シート
作成する行 −−− 作成行
四角形に表示する文字列 −−− 表示文字列
到着時刻
出発時刻
作業開始時刻
作業終了時刻
hh −−− 作図シートの時間を表すセルのセル幅
Reccolor −−− 四角形の塗りつぶしの色（RGB）
前にも上記を掲載しました。
現状は、
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
sht.Cells(idx, 8).Value, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
となっていますよね？
注目するのは、sht.Cells(idx, 8).Value です。
出発便名 つまり、sht.Cells(idx, 4).Value これですが、
出発便名が入力されていれば、当然、出発時刻、すなわちsht.Cells(idx, 8).Valueは、入力されていますよね？
逆に出発便名が未入力ならば、出発時刻、すなわちsht.Cells(idx, 8).Valueも未入力ですよね？ sht.Cells(idx, 8).Valueが未入力のまま、作図2を呼び出してしまうと、正しく四角形が作成されません。
そこで登場したのが、変数 出発時刻なのです。
出発時刻が入力されていたら、
変数 出発時刻に出発時刻があるセルの値を設定
出発時刻が設定されていないときは、
変数 出発時刻 に作業終了時刻を設定
変数 出発時刻は、 sht.Cells(idx, 8).Valueの代わりに使うのです。
以上です。
（ichinose） 2013/11/27(水) 18:49
実現したいことに対して
「こうすればできるかな」「ああすればできるかな」という方向だけでなく
「それができるとしたら一つ前はどういう状態になっているか、どうなって
いる必要があるか」という、逆の方向からも考えてみてください。
「こうでなければそれは実現できない」というのが必ずあります。
いろいろ試すより、逆算するほうが早いです。
よーく考えて、方向性が決まったらコードを書きます。
それでうまくいかなかったら、コードはいったん元に戻して、
考えた内容が間違いだったのか
考えたとおりのコードが書けていなかったのか切り分けます。
（どちらが原因かによって、次の動作が変わりますよね？）
（ 佳 ） 2013/11/28(木) 11:29
返信が遅くなり申し訳ありません。
良きアドバイス有難うございます。もう感謝しかありません。
ichinose様から、詳しくご教示下さるものの、理解不足で、大変ご迷惑をお掛けしています。
佳さんのアドバイス活かし、逆方向からも考えてみます。
ichinose様
何度もすみません。
頑張ります。それしか言葉が見当たりません。
今まで、ichinoseさんに教えてもらった事を振り返りながら、考えてみます。
(yuri) 2013/11/29 0:19
いつもお世話になります。
下記コードが私なりに考えたコードです。
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
出発時刻, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
rw = rw + 2 'sheet2の作図行を2つ増やす
Loop
End Sub
これにより、作図はするようになりました。
しかしながら「型が一致しません」とでて、
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 ここの部分が黄色になります。これは、所々のセルで空欄セルがあるからでしょうか？
確かに、図は47行までは作図され、１０行の空欄セルがあって、57行から125行まで（途中空欄セルあり）ありますが、この部分の図は表示されていません。
よろしくご教示お願いします。
(yuri) 2013/11/30 17:23
>Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
> If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
> If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
'↑このIf文は、この１行で完結しているので↓の行と字下げは、同じ位置で・・・
> Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
> If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
> dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
> 出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
> Else
> dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
> 出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
> End If
> Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
> sht.Cells(idx, 7).Value, _
> 出発時刻, _
> sht.Cells(idx, 11).Value, _
> sht.Cells(idx, 13).Value, _
> hh, carray((rw - 4) / 2 Mod 5))
> End If
> idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
> rw = rw + 2 'sheet2の作図行を2つ増やす
> Loop
おおよそ良いですが、
実は、あと一文、位置が違いますが、これは、その内、気が付いて頂けるでしょう。
さて、
>しかしながら「型が一致しません」とでて、 > 出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 >ここの部分が黄色になります。これは、所々のセルで空欄セルがあるからでしょうか？
この 出発時刻 = sht.Cells(idx, 8).Value というステートメントを実行するには、
必ず、 グループ名、到着便名、到着時刻、作業開始時刻、作業終了時刻が入力されていることが条件です。
しかも、出発便名も入力されている必要があります。 ここで、出発便名が入力されている場合、出発時刻も入力されている と 解釈しています。
出発便名が入力されているのに出発時刻がきちんと入力されていないと 「型が一致しません」というエラーが発生する可能性があります。
出発便名が入力されているのに 出発時刻が入力されていない場合も 多々あるなら、これについて考えなければなりません。
・出発便名が入力されている場合、出発時刻は必ず入力するようにする
・出発便名が入力されている場合、出発時刻セルにただしく時刻が入力されているかをチェックする
どちらかで対処してください。
個人的には、今の段階では、 >出発便名が入力されている場合、出発時刻は必ず入力するようにする
で行う方が良いと思いますが・・・。
もう少し全体の流れがきちんと把握できてから、 違う仕様（出発時刻セルにただしく時刻が入力されているかをチェックする）を考えても遅くない
と思いますけどねえ！！
それから、
>図は47行までは作図され、１０行の空欄セルがあって、57行から125行まで（途中空欄セルあり）ありますが、この部分の図は表示されていません。
何故、間に１０行空欄を作る必要があるのですか？ 入力データは、簡単な構造にするのがよいです。 １０行空ける必要性がないのなら、空けないでデータを連続させた方がよいですよ！！ これも今の段階では・・・。
（ichinose） 2013/12/02(月) 06:13
ご教示有難うございます。
「型が一致しません」の原因がわかりました。 sheet4の仕様は、行先（方面）で３つのブロックに分かれています。(例えば、ヨーロッパ方面、アメリカ方面、アジア方面)に。
で、そのブロックの先頭行に
到着便名 出発便名 到着時刻 出発時刻 担当グループ名 作業開始時間 終了時間 表示
が入力してあるからでした。
これを消したら、一番下のグループまでエラー無く表示されました。
>何故、間に１０行空欄を作る必要があるのですか？
3つのブロックそれぞれ数行の空欄行を設けてある理由ですが、日によって便数が若干増減するので、空けています。
確かに、簡単な構造が良いとはおもいますが、３つのブロックに分けてあるのも、見やすいからもあります。
なので、今の作図は、空欄の行分は空けて作図されているので、出来れば上から詰めて図が表示されればと思います。
今のsheet2の図表示は236行が一番下のグループですが、最終目標のグループ名が重複した場合、同じグループ名に作図する。が目標なので、大分行も少なくなるとは思います。
今の段階では、私の技量では、無理ですかね〜？
あと、
>実は、あと一文、位置が違いますが、これは、その内、気が付いて頂けるでしょう。
えっ・・そうですか〜。考えてみます。
どうか、よろしくお願いします。
(yuri) 2013/12/02 10:45
>今の段階では、私の技量では、無理ですかね〜？ 現状は、全くの空欄行であれば、必須データが入力されていなければ、作図はされないので 大きい問題は起きないと思います。が、何故、作図されないかを きちんと把握されているか？ ということです。把握されていれば、何らかの仕様の変更があっても対応出来ると思いますから・・・。
>今の作図は、空欄の行分は空けて作図されているので、出来れば上から詰めて図が表示されればと思います。
これが正に
>実は、あと一文、位置が違いますが、これは、その内、気が付いて頂けるでしょう。
の原因です。もう既に現象の違和感には、気づかれていることになります。
> rw = rw + 2 'sheet2の作図行を2つ増やす
問題は、↑このステートメントの位置です。
この変数rwって、Sheet2の作図する行ですよね（sht.Cells(idx, 15).Valueの値によって、rw+1になることはありますが）？
現状は、作図条件を満たしてもいなくても
rw = rw + 2
が実行されています。
よって、作図しないときも次の作図行が+2されてしまうので、行が空いてしまうのです。
これを作図した時だけ +2するのです。
さて、どうすれば？
これが出来たら、いよいよ当初名前を挙げたDictionaryオブジェクトです。
（ichinose） 2013/12/02(月) 17:09
お世話になります。
>作図した時だけ +2するのです。
考えてみました。下記コードです。
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 9).Value <> "" Then rw = rw + 2 Else rw = rw 'sheet2のグループ名が入力されていれば作図行を2つ増やす。なければ１行増やす
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 '表示する文字列を編集
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
出発時刻, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
Loop
End Sub
どうでしょうか？
(yuri) 2013/12/02 20:23
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 9).Value <> "" Then rw = rw + 2 Else rw = rw 'sheet2のグループ名が入力されていれば作図行を2つ増やす。なければ１行増やす
↑入れ子の字下げ 気を付けてください。大事ですよ！！
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 9).Value <> "" Then rw = rw + 2 Else rw = rw 'sheet2のグループ名が入力されていれば作図行を2つ増やす。なければ１行増やす
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 表示する文字列を編集
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
出発時刻, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
Loop
End Sub
これで作動はするでしょうねえ・・・、
但し、
If sht.Cells(idx, 9).Value <> "" Then rw = rw + 2 Else rw = rw
これより上のIf文で
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
というステートメントがあります。
このチェックをパスしてきているのですから、この時点では
sht.Cells(idx, 9).Value <> "" グループ名に何か入力は必ずされています。 ですから、ここでIf文で確認する必要はありません。
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
If sht.Cells(idx, 15).Value = "下" Then mkrw = rw + 1 Else mkrw = rw
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
rw = rw + 2 'sheet2の作図行を2つ増やす。
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 表示する文字列を編集
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
出発時刻, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((rw - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
Loop
End Sub
以上で復習終了です。再度、このコードの意味や字下げの重要性を確認してください。
では、以下にDictionaryオブジェクトを使用して、同じグループ名ならば、 同一行に作図するコードを提示します。
Dictionaryオブジェクトについては、一か月前から、このオブジェクトを使うと明言していましたので、ここでは、説明しません。
以下に提示するコードをご自分でこのオブジェクトを調べた結果から、考察してみてください。
Sub 新ガントチャート2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim mkrw As Long
Dim col As Long
Dim carray As Variant
Dim sumwidth As Single
Dim sht As Worksheet
Dim dstr As String
Dim 出発時刻 As Date
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
Set sht = Worksheets("sheet4")
With sht
row1 = .Cells(.Rows.Count, "i").End(xlUp).Row
End With
With Worksheets("sheet2")
On Error Resume Next
.DrawingObjects.Delete
.Columns("a:a").ClearContents
.Range("a2").Value = "グループ名"
On Error GoTo 0
For idx = 1 To ss - 1
sumwidth = sumwidth + .Columns(idx).ColumnWidth
Next
hh = .Range("b:b").ColumnWidth
End With
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目)
rw = 4 'sheet2の作図開始行をrwに設定 (作図開始行4行目)
Do Until idx > row1 'sheet4のデータ読み込み行が最終行を超えるまでループ
If sht.Cells(idx, 3).Value <> "" And sht.Cells(idx, 7).Value <> "" And sht.Cells(idx, 9).Value <> "" And sht.Cells(idx, 11).Value <> "" And sht.Cells(idx, 13).Value <> "" Then '必須項目のチェック
If dic.Exists(Trim(sht.Cells(idx, 9).Value)) Then
mkrw = dic(Trim(sht.Cells(idx, 9).Value))
Else
mkrw = rw
rw = rw + 2
dic.Add Trim(sht.Cells(idx, 9).Value), mkrw
End If
Worksheets("sheet2").Cells(mkrw, 1).Value = sht.Cells(idx, 9).Value 'sheet2にグループ名を設定
If sht.Cells(idx, 15).Value = "下" Then mkrw = mkrw + 1
If sht.Cells(idx, 4).Value <> "" Then '出発便名が入力されていたら？
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 8).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 8).Value '今までどおり出発時刻があるセルを代入 表示する文字列を編集
Else
dstr = sht.Cells(idx, 3).Value & " 到着 : " & Format(sht.Cells(idx, 7).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " *** : " & Format(sht.Cells(idx, 13).Value, "hh:mm")
出発時刻 = sht.Cells(idx, 13).Value '作業終了時刻を代入
End If
Call 作図2(Worksheets("sheet2"), mkrw, dstr, _
sht.Cells(idx, 7).Value, _
出発時刻, _
sht.Cells(idx, 11).Value, _
sht.Cells(idx, 13).Value, _
hh, carray((dic(Trim(sht.Cells(idx, 9).Value)) - 4) / 2 Mod 5))
End If
idx = idx + 1 'sheet4のデータ読み込み行を１つ増やす
Loop
Set dic = Nothing
End Sub
Dictionaryオブジェクトは、よく使うオブジェクトです。是非、マスターしてください。
前スレッドも合わせて、約２ヵ月の間、私の投稿の仕方にお付き合いいただきました。
投稿のコードには、まだ、データチェック等に甘い個所がありますから、 Dictionaryと合わせて、よくトレースしてみてください。
それから、プログラムの要である 繰り返し処理（ループ）、分岐処理（If文）の 基礎練習をなさることをお奨めします。
（ichinose） 2013/12/03(火) 07:56
今まで、詳しく教えて頂きほんとうに有難うございました。そして、お世話になりました。
入れ子の字下げ、気を付けます。 > sht.Cells(idx, 9).Value <> "" グループ名に何か入力は必ずされています。 ですから、ここでIf文で確認する必要はありません。
そうかぁ、なるほどです。
Dictionaryオブジェクトのご教示ありがとうございます。 勉強します。
> それから、プログラムの要である 繰り返し処理（ループ）、分岐処理（If文）の 基礎練習をなさることをお奨めします。
そうですね。今まで、教えてもらった事を、無駄にしない為にも、これから練習していきます。 本当に、２ヶ月間有難うございました。 又、困った時は、よろしくお願いいたします。
(yuri) 2013/12/04 07:09
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.