[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『１日の作業工程をガントチャート表示にしたい』（yuri）
１日を（05時～01時）時間単位（１０分単位）で作業工程をガントチャート表示にして
表したいと思っています。色々調べて、フリーのガントチャートをDLして試してみまし
たが、ピッタリ合わずでした。どうかご教示ください。
sheet1は各作業工程（作業時間）を入力するDATA用として使用します。
作成している内容は、
A B C D E F G H I J
10 第1グループ 便名 到着時間 便名 出発時間
11 ○○便 06:00 ○○便 08:00 ・・・・・・
12 作業時間 6:15 ～ 7:30 ・・・・・
14 第2グループ 便名 到着時間 便名 出発時間・・・・・
15 ○○便 09:00 ○○便 10:30 ・・・・・
16 作業時間 9:15 ～ 10:00・・・・・
と言うふうにセルC,D,E,Fで１回の作業となっており、セルG以降はC,D,E,F,が １０回同じのが繰り返ります。 縦のグループですが、各グループの間に１行開けて、第30グループまであります。 sheet2はガントチャート表で、内容は A B C D E F G H I J K L ・・・・・ 1 5時 6時 ・・・・・01時まで 2 10 20 30 40 50 10 20 30 40 50 ・・・・・ 3 第1グループ ------------------------------------------------------------------------ 4 5 第2グループ ------------------------------------------------------------------------ 6 7 第3グループ -------------------------------------------------------------------------- 8 と言うふうな作りになっています。チャートの表示については、sheet1のdata入力で 各グループ共、最初の作業から５回目の作業まで上段（第2グループのチャートを例に しますと５行目に、６回目以降は下段（６行目）にチャートが入ります。 又、便/到着時間・便/出発時間で一つのチャートが入り、そのチャートに重ねて作業 時間のチャートを入れたいと思います。 どうかご教授下さい。お願いします。 [Excel2010 / OS win7]
なかなか回答が付かないので確認ですが、10分ごとのスケールで、15 分というのはどの ように表示したいのでしょうか。 また、1時間を5セルで、というように見えるのですが、そうすると1セルは10分スケール ではなくなりますよね？
ガントチャートはセルに■などの文字ではなく、オートシェープなどを使いたいのでしょうか。 あと、時間の範囲は AM 5:00 ～ PM 1:00 でしょうか。明けて AM 1:00 まででしょうか。 (Mook)
VBAを知っているという前提のサンプルコードです。
新規ブックにて（左端から Sheet1、Sheet2、Sheet3というシートがあるブック）にて、
標準モジュール（Module1）に サンプルデータ及び、ガントチャート作成シートのレイアウト作成
'================================================================
Option Explicit
Sub mk_sample()
Dim g0 As Long
Dim g1 As Long
With Worksheets("sheet1")
.Cells.ClearContents
.DrawingObjects.Delete
.Columns("a:d").ColumnWidth = 15
.Range("a1:d1").Value = Array("グループ名", "便名", "到着時間", "出発時間")
.Range("a2:d3").Value = [{"第1グループ","ＡＡ便","6:00","8:00";"","作業時間","6:15","7:30"}]
.Range("a4:d5").Value = [{"第2グループ","ＢＢ便","9:00","10:30";"","作業時間","9:15","10:00"}]
.Range("a6:d7").Value = [{"第3グループ","ＣＣ便","7:20","9:00";"","作業時間","7:35","8:45"}]
End With
With Worksheets("sheet2")
.Cells.ClearContents
.DrawingObjects.Delete
.Columns("a:a").ColumnWidth = 15
.Columns("b:bc").ColumnWidth = 5
g1 = 5
For g0 = 2 To 50 Step 6
With .Range(.Cells(1, g0), .Cells(1, g0 + 5))
.MergeCells = True
.Value = ((g1 - 1) Mod 12) + 1 & "時"
.HorizontalAlignment = xlCenter
With .Offset(1, 0).Resize(, 6)
.Value = Array(0, 10, 20, 30, 40, 50)
.HorizontalAlignment = xlLeft
.NumberFormat = "general"
End With
End With
g1 = g1 + 1
Next
With .Range("a1:a2")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Value = "グループ名"
End With
.Rows("1:2").RowHeight = 13.5
With .Rows("3:10")
.RowHeight = 30
End With
End With
End Sub
標準モジュール（Module2）にガントチャート作成プログラムパック
'======================================================================
'============================================================
Private st_col As Single
Private st_point As Single
Private myscale As Single
Private sswidth As Single
Private mentwidth As Double
Private 公差 As Single
Private 初期値 As Single
Sub open_scale(開始列, 開始列までのセル巾, 目盛り巾, Optional sht As Worksheet)
' チャート作成するシート情報を登録する
' input : 開始列 --チャート作成開始列
' 開始列までのセル巾--- 列幅の合計値
' 目盛り巾------------目盛りとなる列の列幅
' sht -------チャート作成対象シート
If sht Is Nothing Then Set sht = ActiveSheet
With sht.Next
.Columns("a").ColumnWidth = 12
.Columns("b:c").ColumnWidth = 6
mentwidth = .Range("b1:c1").Width - .Range("a1").Width
End With
Call calc_公差_初期値(sht.Next)
st_col = 開始列
st_point = 開始列までのセル巾
myscale = 目盛り巾
sswidth = get_point(myscale)
End Sub
'=========================================================================
Function mk_shape(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, Optional s_type As MsoAutoShapeType = msoShapeRectangle, Optional ByVal sht As Worksheet = Nothing) As Shape
'指定された行に開始位置，巾の情報から、チャートを作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' s_type--作成するオートシェイプの種類（MsoAutoShapeType クラスの定数に準拠）
' sht----チャートを作成するシートオブジェクト
'
'output : mk_shape----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkwidth As Single
Dim mk_inf As Variant
If sht Is Nothing Then Set sht = ActiveSheet
mk_inf = get_mk_locate_inf(rng, 開始, 巾, sht)
mkleft = mk_inf(1)
mkwidth = mk_inf(2)
With rng
Set mk_shape = sht.Shapes.AddShape(s_type, mkleft, .Top, mkwidth, .Height)
End With
End Function
'==========================================================================
Function mk_line(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, Optional ByVal t_rate As Long = 50, Optional ByVal sht As Worksheet = Nothing) As Shape
'指定された行に開始位置，巾の情報から、チャート(ライン）を作成する
'input : rng---作成する行を表すRangeオブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' ｔ_rate----ラインを作成する高さ（top）位置をRng.heghtの割合でRng.Top位置から作成する(0～100で指定）
' 例 rngとしてRange("A1")、t_rateとして、20が指定された場合
' range("a1").top+range("a1").height*t_rate/100 がライン作成する縦位置となる
' sht----チャートを作成するシートオブジェクト
'output : mk_line----作成したShapeオブジェクト
Dim mkleft As Single
Dim mkright As Single
Dim mk_inf As Variant
If sht Is Nothing Then Set sht = ActiveSheet
mk_inf = get_mk_locate_inf(rng, 開始, 巾, sht)
mkleft = mk_inf(1)
mkright = mkleft + mk_inf(2)
With rng
Set mk_line = sht.Shapes.AddLine(mkleft, .Top + .Height * t_rate / 100, mkright, .Top + .Height * t_rate / 100)
End With
End Function
'==========================================================================
Private Function get_mk_locate_inf(ByVal rng As Range, ByVal 開始 As Single, ByVal 巾 As Single, ByVal sht As Worksheet) As Variant
Dim mli(1 To 2) As Single
Dim wk As Single
Dim wk2 As Single
Dim ha As Single
Dim ha2 As Single
Dim cnv_left As Single
Dim cnv_width As Single
wk = Int(開始 / myscale) * myscale
wk2 = (開始 - wk) / myscale
ha = Int(巾 / myscale) * myscale
ha2 = Application.Round((巾 - ha) / myscale, 3)
cnv_left = get_point(wk + st_point)
cnv_width = get_point(ha)
If wk2 = 0 Then
mli(1) = cnv_left + mentwidth * (st_col - 1 + Int((開始 - 0.1) / myscale))
Else
mli(1) = cnv_left + mentwidth * (st_col - 1 + Int((wk - 0.1) / myscale)) + sswidth * wk2
End If
If ha2 = 0 Then
If ha = 0 Then
mli(2) = cnv_width
Else
mli(2) = cnv_width + mentwidth * Int((ha - 0.1) / myscale)
End If
Else
If ha = 0 Then
mli(2) = sswidth * ha2
Else
mli(2) = cnv_width + mentwidth * Int((ha - 0.1) / myscale) + sswidth * ha2
End If
End If
get_mk_locate_inf = mli()
Erase mli()
End Function
'==========================================================================
Private Function get_point(セル幅)
get_point = セル幅 * 公差 + 初期値
End Function
'==========================================================================
Private Sub calc_公差_初期値(sht As Worksheet)
Dim wk1 As Double
Dim wk2 As Double
With sht.Cells(1, 1)
.ColumnWidth = 1
wk1 = .Width
.ColumnWidth = 2
wk2 = .Width
End With
初期値 = wk1 * 2 - wk2
公差 = wk1 - 初期値
End Sub
標準モジュール（Module3）に
Option Explicit
'==============================================================================
Sub main()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim shpnm As String
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
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
idx = 2
rw = 3
Do Until idx > row1
.Cells(rw, 1).Value = sht.Cells(idx, 1).Value
wk = (sht.Cells(idx, 4).Value - sht.Cells(idx, 3).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_shape(.Rows(rw), st, wk * hh, msoShapeRectangle, Worksheets("sheet2"))
With shp
.TextFrame.Characters.Text = sht.Cells(idx, 2).Value & " 到着 : " & Format(sht.Cells(idx, 3).Value, "hh:mm") & " 出発 : " & Format(sht.Cells(idx, 4).Value, "hh:mm")
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.RGB = vbRed
.Fill.Transparency = 0.75
End With
wk = (sht.Cells(idx + 1, 4).Value - sht.Cells(idx + 1, 3).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx + 1, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_line(.Rows(rw), st, wk * hh, 80, Worksheets("sheet2"))
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
idx = idx + 2
rw = rw + 1
Loop
End With
End Sub
使用方法
mk_sampleを実行してください。
Sheet1には、サンプルデータ、Sheet2には、ガントチャート作成用レイアウトが展開されます。
Sheet1に表示されているデータを基にSheet2にガントチャートを作成します。
mainを実行してみてください。 Sheet2にガントチャートが作成されます。
四角形が到着から出発までの時間をあらわし、両矢印が作業時間をあらわしています。
尚、Sheet3は、プログラムが作業シートとして使っていますから、
移動や削除はしないでください。
データ内容はご質問とは違いますが、それは、mainを解析して、本来のデータ用に 変更してみてください。
ichinose
ありがとうございます。
書き方が悪くて申し訳ありませんでした。
10分ごとのスケールで、15 分というのはどのように表示したいのでしょうか?
また、1時間を5セルで、というように見えるのですが、そうすると1セルは10分スケール ではなくなりますよね？
確かに、１時間５セルでは無かったです。すみません。表示についてはichinose様のご教示下さった表示でOKです。
時間の範囲は AM 5:00 ～ PM 1:00 でしょうか。明けて AM 1:00 まででしょうか。
時間については、明けてのAM1：00までです。
Ichinose様
ありがとうございます。
最初に、すみません。VBAは全くの初心者です。
早速、作成して頂いたコードを試してみました。表示の仕方については、大満足です。
私のDATAに合わせながらmain解析してみましたが、ギブアップです。
変更できたのは、時間をAM01:00に伸ばしたのと、２４時間表示にできただけです。
もう少し詳しくお願いします。
・ 一つのグループの１日の作業工程が約10作業（工程）あるので、それに対応した チャートが表示されるコード。
・１つのグループを２段に分け、最初の工程～５回目の工程までを上段に表示、６回目 の工程～最後の工程までを下段に表示されるコード。
をお願いいたします。
(Yuri)
>一つのグループの１日の作業工程が約10作業（工程）あるので、それに対応した > チャートが表示されるコード。 >１つのグループを２段に分け、最初の工程～５回目の工程までを上段に表示、６回目 > の工程～最後の工程までを下段に表示されるコード。
これらのコードを投稿してしまえば、私が全部作ることになってしまいます。 私は、そういう投稿をなるべくしない様にしています。
まず、 C、D、E、F列の一回目のデータだけ、ガントチャートを作成する事を考えてください。
出来たら、コードを提示してください（Mainのコードだけでよいですね）。
次に 5回までのデータでガントチャート作成を考えてください。 これは、ループ処理（Do～Loopか、For～Nextを使う）を使えば可能です。 一回目のデータから2回目に移るためには？ 又、2回目のデータから3回目のデータに移るには？ どうすればよいかを考えてください。何らかの規則があるはずです。それがわかれば、作成することができます。
ループ処理が何なのかわからなければ、ネットを検索したり、Excel/VBAのHelpにも説明がされていますから、研究してみてください。
ここまで出来れば、6回目以降、作成行を変えればよいのですからおそらくできます。
以上のような工程で考えてみては、いかがですか！！
ichinose
色々とヒントをありがとうございます。
これから、ちょっと考えてみます。
(yuri)
ichinose様
すみません。ichinose様がおっしゃる通り、とりあえずC,D,E,Fをガントチャートで表す為、mainのコードを少し変更して、やってみましたが、うまく行きません。
もう少し、詳しくお願いします。
コードの何処を変更するのか、未だ解読できていません。
(YURI)
>mainのコードを少し変更して、やってみましたが、うまく行きません。 どのようにコードを変更したのでしょうか？ コードを提示してください。
VBAの質問の場合、
仕様の提示
機能概要の記述
入力データの詳細説明（例題データの提示）
出力データの詳細説明（例題データの提示）
出来ているコード又は、ご自分で試したコードの提示
までは、私は質問者さんの必須提示項目だと思っています。
YURIさんは、仕様の記述に関しては、初心者とは思えないほどよく記述されている と 私は思います。
ここは、勉強の場ですから、作動しないコードでもよいのでご自分が考えて作成したコードを 提示してください。
作成依頼の掲示板ではないですよね？ もし、作成依頼もよいなら、私も作ってもらいたいですね！！ そうすれば、人件費助かります。
本題です。
前回提示した mk_sampleで作成される ガントチャートの基データ（Sheet1）、 ガントチャートレイアウト（Sheet2）、これとYURIさんの抱えている問題の違いは？
基データの記述されているセル番地の違いだけですよね！！ Sheet2のレイアウトが
>時間をAM01:00に伸ばしたのと、２４時間表示
というのは、ここでは、それほど大きい問題ではありません。
mk_sampleで作成された Sheet1のデータを見てみると・・・、
到着時刻、出発時刻は、それぞれ Ｃ列、Ｄ列（四角形の作図に使用） 作業の開始・終了時刻もそれぞれ Ｃ列、Ｄ列（両矢印の作図に使用）
ですね！！
又、データ開始行は２行目から、開始され、一つのグループで２行使っていますよね？
次にmainというプロシジャーをみてみましょう。
'==============================================================================
Sub main()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim shpnm As String
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
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
idx = 2
rw = 3
Do Until idx > row1
.Cells(rw, 1).Value = sht.Cells(idx, 1).Value
wk = (sht.Cells(idx, 4).Value - sht.Cells(idx, 3).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_shape(.Rows(rw), st, wk * hh, msoShapeRectangle, Worksheets("sheet2"))
With shp
.TextFrame.Characters.Text = sht.Cells(idx, 2).Value & " 到着 : " & Format(sht.Cells(idx, 3).Value, "hh:mm") & " 出発 : " & Format(sht.Cells(idx, 4).Value, "hh:mm")
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.RGB = vbRed
.Fill.Transparency = 0.75
End With
wk = (sht.Cells(idx + 1, 4).Value - sht.Cells(idx + 1, 3).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx + 1, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_line(.Rows(rw), st, wk * hh, 80, Worksheets("sheet2"))
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
idx = idx + 2
rw = rw + 1
Loop
End With
End Sub
ループ処理の中で行っているのがSheet1の一つのグループに対するSheet2への作図です。
idx = 2 'Sheet1の基データの2行目から参照する
rw = 3 'Sheet2のガントチャート作成開始行
・
・
.Cells(rw, 1).Value = sht.Cells(idx, 1).Value '１ グループ名をセット
'↓２ 四角形の作図
wk = (sht.Cells(idx, 4).Value - sht.Cells(idx, 3).Value) / TimeSerial(0, 10, 0)
’↑２－１ 到着から出発の時間から10分間隔のセル幅の使用数の計算
st = (sht.Cells(idx, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
' ↑２－２ 四角形作図開始位置の計算
Set shp = mk_shape(.Rows(rw), st, wk * hh, msoShapeRectangle, Worksheets("sheet2"))
With shp
.TextFrame.Characters.Text = sht.Cells(idx, 2).Value & " 到着 : " & Format(sht.Cells(idx, 3).Value, "hh:mm") & " 出発 : " & Format(sht.Cells(idx, 4).Value, "hh:mm")
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.RGB = vbRed
.Fill.Transparency = 0.75
End With
' ↑２－３ 計算値から、四角形の作図と色やテキストの設定
'↓３ 両矢印線の作図
wk = (sht.Cells(idx + 1, 4).Value - sht.Cells(idx + 1, 3).Value) / TimeSerial(0, 10, 0)
’↑３－１ 作業開始時間から10分間隔のセル幅の使用数の計算
st = (sht.Cells(idx + 1, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
' ↑３－２ 両矢印線作図開始位置の計算
Set shp = mk_line(.Rows(rw), st, wk * hh, 80, Worksheets("sheet2"))
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
' ↑３－３ 計算値から、両矢印線の作図
idx = idx + 2 '４ 次のグループのデータがある行に変数idxを設定する
rw = rw + 1 '５ 次のグループのチャート作図行に変数rwを設定する
以上、簡単にコメントを付けました。
２－１
wk = (sht.Cells(idx, 4).Value - sht.Cells(idx, 3).Value) / TimeSerial(0, 10, 0)
sht.Cells(idx, 4).Value これは、Sheet1のidx行の第4列のセルの値です。 つまり、出発時刻（Ｄ列）の値です
sht.Cells(idx, 3).Value) これは、Sheet1のidx行の第3列のセルの値です。 つまり、到着時刻（Ｃ列）の値です
3とか4は、Ａ列から、1,2,3・・・と数えた数字です。
さて、本データの到着時刻、出発時刻に変えるには？
同じ要領で ２－３、３－１、３－２をどのように変えればよいのでしょうか？
４ や ５は（初期設定も含めて）、変更する？ それともしないのか？
考えてみてください
ichinose
何度もありがとうございます。又、分かり易くご教授して頂き感謝しております。
vbaに関しては、私も以前から勉強をして少しでも覚えなくては・・・と思ってはいたものの、難しくて・・。
ichinose様のおっしゃる通り、私は皆さんに作業依頼をお願いしているような感じですね。申し訳ありません。
さて、ichinoseさんが詳しく書かれた事を基DATAに当てはめながら一つづつやってみました。途中、色々とエラーも出ましたが、なんとか第一段階はできたみたいです。
こんな感じでmainのコードを変更してみました。
Sub main()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim st As Single
Dim wk As Double
Dim shp As Shape
Dim shpnm As String
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
Call open_scale(ss, sumwidth, hh, Worksheets("sheet2"))
idx = 11
rw = 3
Do Until idx > row1
.Cells(rw, 1).Value = sht.Cells(idx, 1).Value
wk = (sht.Cells(idx, 5).Value - sht.Cells(idx, 3).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx, 3).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_shape(.Rows(rw), st, wk * hh, msoShapeRectangle, Worksheets("sheet2"))
With shp
.TextFrame.Characters.Text = sht.Cells(idx, 2).Value & " 到着 : " & Format(sht.Cells(idx, 3).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 5).Value, "hh:mm")
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.RGB = vbRed
.Fill.Transparency = 0.5
End With
wk = (sht.Cells(idx + 1, 5).Value - sht.Cells(idx + 1, 4).Value) / TimeSerial(0, 10, 0)
st = (sht.Cells(idx + 1, 4).Value - TimeSerial(5, 0, 0)) / TimeSerial(0, 10, 0) * hh
Set shp = mk_line(.Rows(rw), st, wk * hh, 80, Worksheets("sheet2"))
With shp
.Line.ForeColor.RGB = vbBlack
.Line.Transparency = 0
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.BeginArrowheadStyle = msoArrowheadTriangle
End With
idx = idx + 2
rw = rw + 1
Loop
End With
End Sub
これで、とりあえず最初の１回目作業は表示できるようになったので、２回目以降の作業が表示できるように、次の段階としてDo～Loopと言うのを研究してみます。
またよろしくお願いいたします。
(yuri)
これは、ループ処理（Do～Loopか、For～Nextを使う）を使えば可能です。
一回目のデータから2回目に移るためには？ 又、2回目のデータから3回目のデータに移るには？ どうすればよいかを考えてください。何らかの規則があるはずです。それがわかれば、作成することができます
ichinoseさんがヒントを下さった”何らかの規則”が分かりませんでした。
○ 順番に参照する方法と色々を探していると見つけたのですが、
Dim LoopArea As Range
Set LoopArea = Selection
For i = 1 To LoopArea.Count
LoopArea.Cells(i).Value = i
Next
結局使い方が？？ わからずです。
再度、ご教授願います。
(yuri)
>”何らかの規則”が分かりませんでした。
規則性と言ってもその殆どが等差数列です。それ以外だと結構難しい仕様だと思います。
例えば、
1 4 7 10 13 16 19 22
というような数字がある場合、 1～4の差は3、4～7の差は、3、・・・・・19～22の差は、3
隣どうしの数字の差が3という規則が見つかります。
この数字を順に表示するコードは、・・・。
標準モジュールに
Sub test()
Dim 公差 As Long
Dim 値 As Long
公差 = 3
値 = 1 '初項設定
Do Until 値 > 22
MsgBox 値
値 = 値 + 公差
Loop
End Sub
こんなコードになります。
問題に戻って・・・。
1回目の列番号、2回目、3回目とみてください
1回目
2列目 ○○便の名称 3列目 到着時刻 5列目 出発時刻
2回目
・ ・
と記述していけば、列番号に一定の規則が見えてきませんか？
つまり、同じ間隔で設定されているはずなんですが・・・。
調べてみてください
ichinose
ありがとうございます。
今現在の構成ですと
A | B C D E | F G ・
9 | 1回目作業 | 2回目作業
10 グループ名 | 到着便名 到着時刻 出発便名 出発時刻 |到着便名 到着時刻
11 第1グループ | AA便 07:30 BB便 09:00 |
12 | 作業時間 07:40 8:30 |
A | B C D E | F G ・
13 | 1回目作業 | 2回目作業
14 グループ名 | 到着便名 到着時刻 出発便名 出発時刻 |到着便名 到着時刻
15 第2グループ | CC便 06:30 DD便 08:00 |
16 | 作業時間 06:40 7:30 |
と言うふになりまして、列番号の一定の規則は２列目、３列目、４列目、５列目までの４列で一つの作業になっています。２回目以降も同じ間隔になっています。
それで、公差=3 とか値=1が関係するんですね？ 値はスタート位置で公差は３つ飛ばしとか４つ飛ばしとか・・・？？
違っていたらすみませんです。
(yuri)
>それで、公差=3 とか値=1が関係するんですね？ 値はスタート位置で公差は３つ飛ばしとか４つ飛ばしとか・・・？？
そういうことです！！
到着便名に着目すれば、一回目の到着便名のある列番号は、Ｂですから、2ですよね！！
2回目の到着便名のある列番号は、Ｆですから、6ですよね！！
3回目のそれは、Jですから 10ですね！！
そうすると 最初の値が2で以降、４ずつ増加する。
これで2回目、3回目の到着便名のあるセルの列番号は、前回コードの例のような繰り返し処理を 行えば取得できますよね！！
値に到着便名のあるセルの列番号が取得できれば、
到着時刻のあるセルの列番号は 値+1 出発便名のあるセルの列番号は 値+2 出発時刻のあるセルの列番号は 値+3 作業時間開始時刻あるセルの列番号は 値+2（行番号も一つ下） 作業時間終了時刻あるセルの列番号は 値+3（行番号も一つ下）
作図をするのに必要なデータが取得できます。 後は、このループ内に作図を行うコードを記述する
という手順です。
繰り返しは処理、規則性を導き出し、それをコード化する。
プログラムの要です。これが出来ないとプログラムは、つくれない と言ってもよいと思います。
もうちょっとですよ！！
ichinose
値に到着便名のあるセルの列番号が取得できれば
の取得ですが、
worksheets("sheet1").cells(11,2).valueで到着便名が取得できますか？
色々と試してはいるものの、エラーばかりで・・・
スムーズに先に行けなくて申し訳ありません。
(Yuri)
>worksheets("sheet1").cells(11,2).valueで到着便名が取得できますか？
この↑値で到着便名が取得できているから、Yuriさんが投稿されたコード
>.TextFrame.Characters.Text = sht.Cells(idx, 2).Value & " 到着 : " & Format(sht.Cells(idx, 3).Value, "hh:mm") & "／" & sht.Cells(idx, 4).Value & " 出発 : " & Format(sht.Cells(idx, 5).Value, "hh:mm")
で四角形内にテキストが正しく表示されているのですよね！！
コード内の
→ sht.Cells(idx, 2).Value がそうですね！！(shtはWorksheets("Sheet1")を指しています）
idx=11 と初期設定されています。つまり、ループ処理の最初で
11行目のＢ列の到着便名を取得できています。
idxという変数をループ内で変化させることによって、11行目、13行目、15行目のデータが取り出せます。
sht.Cells(idx, 2).Value 列方向の値は、2と定数を入れているのでこのままでは、 2 つまり、Ｂ列の値だけしか取得できませんよね！！
ここも行と同じく変数を使うのです。仮にその変数を JDX とします そのJDXを使って（行の繰り返し処理の中にもう一つの繰り返し処理）、ループ処理を構築します。 ループの外でJDXに初期値を与え、そのループ内では、見出した規則性でJDXを変化させます。
JDXの変化で作図に必要な 1回目のデータ、2回目のデータ、・・・が取得できるはずです。
>色々と試してはいるものの、エラーばかりで・・・
再度、考えてみてください。その上で作動しないらば、その作動しないコードを提示してください
そうしないと、どこが理解して頂いていないのかがわかりませんので・・・。
日中は、返信はできませんが・・・。
ichinose
>こんな感じでmainのコードを変更してみました。 と仰って投稿されたコードを以下のように変更しました。
'===============================================================================================================
Sub main2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
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"))
idx = 11
rw = 3
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 2).Value, sht.Cells(idx, 3).Value, sht.Cells(idx, 4).Value, _
sht.Cells(idx, 5).Value, sht.Cells(idx + 1, 4).Value, sht.Cells(idx + 1, 5).Value, hh)
idx = idx + 2
rw = rw + 1
Loop
End Sub
'===============================================================================================================
Sub 作図(ByVal シート As Worksheet, ByVal 作成行 As Long, 到着便 As String, ByVal 到着時刻 As Date _
, ByVal 出発便 As String, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date, ByVal 作業終了時刻 As Date, hh As Single)
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 = 到着便 & " 到着 : " & Format(到着時刻, "hh:mm") & "／" & 出発便 & " 出発 : " & Format(出発時刻, "hh:mm")
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Fill.ForeColor.RGB = vbRed
.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
これでループ内では、作図に必要なデータを「作図」というプロシジャーに送れば、 チャートを作成するように変更しました。 (標準モジュール（Module2）にガントチャート作成プログラムパックは、必要です）。
作図に必要なデータは、
ガンチャート作成するシートオブジェクト ガンチャート作成する行 到着便 到着時刻 出発便 出発時刻 作業開始時刻 作業終了時刻 hh(10分を表すセル幅）
です。
この内、作成するシートオブジェクトとhhは、例題のようにworksheets("sheet2") 及び、hh
で固定でよいです。
残りのデータを行と何回目の作図かでデータを変えなければなりません（ここが問題のループ処理です）。
提示したコードは、グループ毎には、作図されていますよね！！ これは、
idx = 11
rw = 3
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 2).Value, sht.Cells(idx, 3).Value, sht.Cells(idx, 4).Value, _
sht.Cells(idx, 5).Value, sht.Cells(idx + 1, 4).Value, sht.Cells(idx + 1, 5).Value, hh)
idx = idx + 2
rw = rw + 1
Loop
上記のDo Until ～ Loop
の繰り返し処理で各グループの一回目のデータをプロシジャー「作図」に渡しているからです。
では、一回目以降、2回目、3回目・・・5回目までも作図するには、
上記のDo Until ～ Loop内で更に一回目以降、2回目、3回目・・・5回目までのループ処理を コード化しなければなりません。その場合、一例ですが、sht.Cells(idx, 2).Valueの2の数値も 変数化する必要があります。
新規ブックの標準モジュール（Module1）に以下のコード記述し、実行してみてください
Sub 参考コード()
Dim rw As Long
Dim col As Long
rw = 1
col = 1
Do Until rw > 4
col = 1
Do Until col > 4
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 1
Loop
rw = rw + 1
Loop
End Sub
上記のコード「参考コード」 セルA1から、B1,C1,D1と移っていき、A2,B2,C2,D2と移り、A3,B3,C3,D3,A4,B4,C4,D4と移り 終了するというそれだけの仕様のコードです。
これらを参考に完成させてください
ichinose
お世話になっています。
色々と細かくご教示していただき、ありがとうございます。
では、一回目以降、2回目、3回目・・・5回目までも作図するには、
上記のDo Until ～ Loop内で更に一回目以降、2回目、3回目・・・5回目までのループ処理をコード化しなければなりません。その場合、一例ですが、sht.Cells(idx, 2).Valueの2の数値も変数化する必要があります。
それで、私が思いついたのが、下記のコードです。
idx = 11
rw = 3
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 2).Value, sht.Cells(idx, 3).Value, sht.Cells(idx, 4).Value, _
sht.Cells(idx, 5).Value, sht.Cells(idx + 1, 4).Value, sht.Cells(idx + 1, 5).Value, hh)
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 6).Value, sht.Cells(idx, 7).Value, sht.Cells(idx, 8).Value, _
sht.Cells(idx, 9).Value, sht.Cells(idx + 1, 8).Value, sht.Cells(idx + 1, 9).Value, hh)
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 10).Value, sht.Cells(idx, 11).Value, sht.Cells(idx, 12).Value, _
sht.Cells(idx, 13).Value, sht.Cells(idx + 1, 12).Value, sht.Cells(idx + 1, 13).Value, hh)
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 14).Value, sht.Cells(idx, 15).Value, sht.Cells(idx, 16).Value, _
sht.Cells(idx, 17).Value, sht.Cells(idx + 1, 16).Value, sht.Cells(idx + 1, 17).Value, hh)
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 18).Value, sht.Cells(idx, 19).Value, sht.Cells(idx, 20).Value, _
sht.Cells(idx, 21).Value, sht.Cells(idx + 1, 20).Value, sht.Cells(idx + 1, 21).Value, hh)
idx = idx + 2
rw = rw + 1
Loop
End Sub
参考コードは実行してみました。
参考コードのrw = 1を11に、col=1を2に変更し、色々と試行錯誤しています。
まだ時間がかかりそうです。
(yuri)
>それで、私が思いついたのが、下記のコードです。
なるほど、これだと 作動しますよね！！
でも、・・・・。
最終的には、10回目まであるんですよね！！ その時は、同じようなコード（Call 作図（・・・））を10回記述しますか？
作図に必要なデータが4列おきに配置されているとわかっているのに？
因みに前回投稿の 参考コード
Sub 参考コード()
Dim rw As Long
Dim col As Long
rw = 1
col = 1 '←これ削除
Do Until rw > 4
col = 1
Do Until col > 4
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 1
Loop
rw = rw + 1
Loop
End Sub
上記のように訂正してください。動作には、影響ありませんが、コードミスです。
参考コードをよくみてください、
>col=1を2に変更し、色々と試行錯誤しています。
これも試すには、よいですね
あとは、
col = col + 1
これです。
列を一列づつ変化させるから、
col = col + 1
とするのですよね？
一つおきだったら、
col = col + 2
とします。
では、４列ごとだったら、？？？
規則性は、ここで活かすのですよ！！
又、
col=2 ・ ・ msgbox sht.Cells(idx, col).Value
とすれば、２列目の到着便が取得できます。 では、。同じ変数colを使って、到着時刻や出発便、出発時刻等 作図に必要なデータは、変数colを使って取得するには、 どのようにすればよいか？
> 値に到着便名のあるセルの列番号が取得できれば、 >到着時刻のあるセルの列番号は 値+1 >出発便名のあるセルの列番号は 値+2 >出発時刻のあるセルの列番号は 値+3 >作業時間開始時刻あるセルの列番号は 値+2（行番号も一つ下） >作業時間終了時刻あるセルの列番号は 値+3（行番号も一つ下）
これを思い出してみてください
ichinose
ありがとうございます。
試してみました。
col=col+4で到着便を１０回全て取得しています。
あと問題は、到着時刻とかの 値+1とかの部分です。
そのまま値+1とか値+2とかにしても、うまく動かないですよね？？
Sub 参考コード()
Dim rw As Long
Dim col As Long
rw = 11
col = 1
Do Until rw > 14
col = 2
Do Until col > 40
col = 2 + 1
col = 2 + 2
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 4
Loop
rw = rw + 1
Loop
End Sub
このように変えても、無理でした。
変数colを使ってどのように取得すれば？？
がどうしてもわかりません。
細かく教えて下さっているのに、申し訳ありません。
(yuri)
◆このように変えても、無理でした。
◆変数colを使ってどのように取得すれば？？
おそらくいまは、「こうしたらできるかな？」「ああしたらできるかな？」と
考えておられると思います。もちろんそれも大切ですが、それに加えて
「これができたとして そのときcolはどうなっているハズか？」と逆算して
考えてみてください。（迷路をゴールから解くようなもので、うまくいくこと
結構あります。）
－佳－ ※ニックネーム欄が見当たりません
（）
yuriさんは、強敵ですねえ！！
Do Until col > 40
col = 2 + 1
col = 2 + 2
'↑ここで、変数colに2+2、つまり4をDo～Loop内で設定してしまっています
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 4
'colは、4が設定されているのですから、それにcol+4でcolは、8です。
'Do～loop内では、colに最初に4が設定され、それに+4されて8になります
'いつまでたってもcolは、40なんて越えません。超えないのでいつまでも
'ループしっぱなしです。
Loop
Do～Loopは colを変化させながら（4を順々にたしていく）処理をし、条件により、ループから抜ける（ここでは、colが40を超えたらループを抜ける）
というステートメントです。
ですから、ループ内で毎回決まった数字（col = 2 + 2）を設定してしまっては、ループ処理が成立しません。
col = 1
Do Until col > 4
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 1
Loop
提示した参考コードでは、Do～Loop内でcolに直接定数（数字）を設定していませんよね
>変数colを使ってどのように取得すれば？？
以下のコードだと正しく到着便を選択しますよね？
Sub 参考コード()
Dim rw As Long
Dim col As Long
rw = 11
col = 1
Do Until rw > 14
col = 2
Do Until col > 40
Cells(rw, col).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 4
Loop
rw = rw + 1
Loop
End Sub
最初に Cells(rw, col).Select を選択した時、B11を選択しているのですから、変数colには、2が 設定されています。
2度目は、F11が選択されます。この時の変数colは、6が設定されています。
B11が選択されている時、つまり、col=2のとき、到着時刻のセルC11を取得するためには？
colが3になればよいですよね？でも、col=3と数字をループ内でcolに設定できない・・・。
ならば、 Cells(rw, col+1).Value とすれば、colの値も変わりませんし、colという変数を使って 到着時刻のあるセルの列番号を表現できます。
Sub 参考コード()
Dim rw As Long
Dim col As Long
rw = 11
col = 1
Do Until rw > 14
col = 2
Do Until col > 40
Range(Cells(rw, col), Cells(rw, col + 1)).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 4
Loop
rw = rw + 1
Loop
End Sub
このようにすると、今度は、到着便と到着時刻を順次選択していきます。
他のセルも同じ要領で試してみて、うまくいくようなら、本題に戻ってみてください。
(ichinose)
皆様色々とご教示ありがとうございます。
ichinoseさん、あのぅ～強敵なyuriです。
いつも丁寧にご教授しって頂いているのに、理解不足でご迷惑をお掛けしています。
今度はどうでしょう。こんな感じでやってみました。
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, sht.Cells(idx, 2).Value, sht.Cells(idx, 3).Value, sht.Cells(idx, 4).Value, _
sht.Cells(idx, 5).Value, sht.Cells(idx + 1, 4).Value, sht.Cells(idx + 1, 5).Value, hh)
idx = idx + 2
rw = rw + 1
Loop
rw = 11
col = 1
Do Until rw > 20
col = 2
Do Until col > 41
Range(Cells(rw, col), Cells(rw, col + 1)).Select
Range(Cells(rw, col), Cells(rw, col + 2)).Select
Range(Cells(rw, col), Cells(rw, col + 3)).Select
Range(Cells(rw, col), Cells(rw + 1, col + 2)).Select
Range(Cells(rw, col), Cells(rw + 1, col + 3)).Select
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
col = col + 4
Loop
rw = rw + 2
Loop
End Sub
よろしくお願いします。
(yuri)
yuriさんが提示されたコード・・・、 Cells(rw, col)という指定で 到着便を示すセルが取得できたとき、
Cells(rw, col + 1)が 到着時刻 Cells(rw, col + 2)が、出発便 Cells(rw, col + 3)が、出発時刻 Cells(rw + 1, col + 2)が、作業開始時刻 Cells(rw + 1, col + 3)が、作業終了時刻
それぞれのセルを表していることが理解できましたか？
参考コードでは、セルを選択しただけですが、
元のコードに戻って、1回目の作図までは出来ているのですから、 2回目、3回目、・・・5回目の作図ができるようにコードを作成してください。
（ichinose ） 2013/10/18(金) 18:36
ありがとうございます。
>それぞれのセルを表していることが理解できましたか？ はい、ようやく理解できました。
これから、１回目の作図を参考に、２回目以降の作図コードを考えてみます。
(yuri)
本当に、今までご教授ありがとうございます。
もう一度、最初からご教示下さった事を整理し、変数について調べ、ようやく、ここまでできました。
できたのが、下記コードです。
idx = 11
col = 2
rw = 3
Do Until idx > row1
col = 2
Do Until col > 41
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, 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)
col = col + 4
Loop
idx = idx + 2
rw = rw + 1
Loop
End Sub
しかし、sheet2のチャートで、作業時間の部分で線が入るのですが、もう１本多く入ってしまいます。線の入る場所は最初から時間で言うと17：00くらいまで入ります。
各回の枠の中には作業開始から終了までの線は、きちんと入っているのですが、その上に
17:00頃まで長い線が入ってしまいます。
どうしてでしょうか？
(yuri)
>もう１本多く入ってしまいます。線の入る場所は最初から時間で言うと17：00くらいまで入ります。
このデータ（到着便から作業終了時刻のすべてです）を見せてください。
（ichinose） 2013/10/22(火) 09:13
このようになっています。
Sub main2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim col As Long
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"))
idx = 11
col = 2
rw = 3
Do Until idx > row1
col = 2
Do Until col > 41
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, 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)
col = col + 4
Loop
idx = idx + 2
rw = rw + 1
Loop
End Sub
(yuri)
コードの提示もですが、Sheet1のデータです。
その >もう１本多く入ってしまいます
というSheet1のデータを1行でよいですから、全部みせてください
（ichinose） 2013/10/22(火) 18:33
sheet1はこのようになっています。
A | B C D E | F G HI
9 | 1 | 2
10 グループ名 | 到着便名 到着時間 出発便名 出発時間 |到着便名 到着時間
11 第1グループ | 1便 07:30 2便 09:00 | ３便 10:00
12 | 作業時間 07:40 8:30 | 作業時間
B C D Eで１回の作業として、F列から２回目の作業でAO列まで１０回の作業としています。１０回目の作業まで全部記したほうがよいですかね？うまく入力できなくて・・・
(yuri)
>１０回目の作業まで全部記したほうがよいですかね？ そうですね！！
（ichinose） 2013/10/22(火) 21:46
了解しました。
A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL AM AN AO
1 2 3 5 6 7 8 9 10
10 グループ名 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間 到着便名 到着時間 出発便名 出発時間
11 第1グループ
12 作業時間 作業時間 作業時間 作業時間 作業時間 作業時間 作業時間 作業時間 作業時間 作業時間
どうしてもずれてしまいますが、このようになっています。
(yuri)
いえ、実際のデータがみたいのです。 不具合がある場合、あるデータに対して、うまくいかない なんてことは よくあることです。
プログラムって、入力データがこんなデータだって想定して作成するんですよね！！ でも、きちんと入力データを把握しきれていない場合、不具合が発生します。
よくこの掲示板でも見かけます。やってみましたが、うまくいきません、何が悪いのでしょうか？
不具合があればトラブルシートというドキュメントを私たちは、プロフラムの作成者に提出しますが、 こんなコメントをされても何が悪いのかわかりません。
入力データを以下のようなデータでプログラムを作動させたところ ｘｘｘｘという結果になり、 仕様どおりの結果になりませんでした。
入力データの提示
・
・
という記述があれば、その不具合のあったデータでプログラムを精査できますよね！！
なので、 >その >もう１本多く入ってしまいます >というSheet1のデータを1行でよいですから、全部みせてください
と、申しました。
気になっているのは、0：15なんて時刻がありませんか？
（ichinose） 2013/10/23(水) 00:21
おはようございます。
>気になっているのは、0：15なんて時刻がありませんか？ すみません。ありました。6回目の作業開始時間が14:45のところ1:45になってました。 これで、余計な線は消えました。
おかげさまで、ようやくここまで来ました。 後、私が行いたいのは6回目以降のチャートは1～5回目の下に描くこと。
と、今10グループほど、作ってみましたが四角のチャートの色が同じ色なので、できればグループも25グループあるので、5色位交互に色分けしたいと思います。
ichinoseさん。更にご教授を、お願いします。
(yuri)
>私が行いたいのは6回目以降のチャートは1～5回目の下に描くこと。 今仕上がっているコードの意味をよく理解てくださいね
作図シートのレイアウトを以下のコードで作成されるようなものに変更しましょう。
標準モジュールに
Sub mk_sample2()
Dim g0 As Long
Dim g1 As Long
With Worksheets("sheet2")
.Cells.Delete
.DrawingObjects.Delete
.Columns("a:a").ColumnWidth = 15
.Columns("b:bc").ColumnWidth = 5
g1 = 5
For g0 = 2 To 110 Step 6
With .Range(.Cells(1, g0), .Cells(1, g0 + 5))
.MergeCells = True
.Value = ((g1 - 1) Mod 24) + 1 & "時"
.HorizontalAlignment = xlCenter
With .Offset(1, 0).Resize(, 6)
.Value = Array(0, 10, 20, 30, 40, 50)
.HorizontalAlignment = xlLeft
.NumberFormat = "general"
End With
End With
g1 = g1 + 1
Next
With .Range("a1:a2")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Value = "グループ名"
End With
.Rows("1:2").RowHeight = 13.5
With .Rows("3:60")
.RowHeight = 15
End With
With .Columns(1)
.Rows("3:4").MergeCells = True
.Rows("3:4").AutoFill Destination:=.Rows("3:62"), Type:=xlFillDefault
End With
End With
End Sub
いかがでしょうか？
要は、一つのグループで 2行使うことにしました。 これで一つのグループで2行の作図ができますよね？
現在のコードをどのように直せばよいか？
まずは、このレイアウトにきちんと今までの状態と同じように 作図するためには、どこを変えればよいか 探ってみてください (1行に１～10回目の作図をする という現在できている仕様を新レイアウトで 実現してください)
違いは、作図シートで 今までは、1行で1グループでしたが、今度は 2行で1グループを作図するんですよね？
色は、これが出来てからにしましょう（こっちの方が簡単？だとおもいますから）
（ichinose） 2013/10/24(木) 04:51
仕様変更ありがとうございます。
なんとか頑張って、下記のようなコードとなりました。
Sub main2()
Const ss = 2
Dim hh As Single
Dim idx As Long
Dim rw As Long
Dim row1 As Long
Dim col As Long
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"))
idx = 11
col = 2
rw = 3
Do Until idx > row1
col = 2
Do Until col > 21
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, 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)
col = col + 4
Loop
idx = idx + 2
rw = rw + 2
Loop
idx = 11
col = 2
rw = 4
Do Until idx > row1
col = 22
Do Until col > 41
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, 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)
col = col + 4
Loop
idx = idx + 2
rw = rw + 2.5
Loop
End Sub
ですが、もっとすっきりした組み方でもあるのでは？と思いながら。でも、わかりませんでした。
(yuri)
よく研究されたと思います。今回は、 rw = rw + 2 これができれば 良い 思っていたので よしとしましょう。
rw = rw + 2.5 これは、いけません。これは、たまたま作動していたんですよ！！
sub test1()
dim rw as long
rw=1
rw=rw+2.5
msgbox rw
end sub
sub test2()
dim rw as long
rw=2
rw=rw+2.5
msgbox rw
end sub
どちらも4と表示されます。
この理由を考察するのもよい勉強になるかと思います。
今回は、ラッキーでしたが、気を付けてください。
もう一つ、
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
これは、グループ名をＡ列に設定するコードです。
Do Until col > 21
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
Call 作図(Worksheets("sheet2"), rw, 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)
col = col + 4
Loop
これを作図と同じループ内で記述していますが、
これ本来、グループ毎いえ、行毎に一回設定すればよいですよね？ 上記のコードは、1回目の作図時、2回目の作図時、・・・10回目の作図時にそれぞれ同じ内容を 設定しています。これもラッキーなんです。たまたま同じ内容の設定だったので うまくいったんです。 同じ内容の設定なら、行につき 一回設定でよいですよね？
ループをグループに付き 上の行の作図と下の行の作図を分けていますが、 変数Colが21以下のときは、上の行、それよい大きい場合は、下の行に作図なんですから、 Colが21以下とそれより上での処理かえればよいです。
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 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"))
idx = 11
rw = 3
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
col = 2
Do Until col > 41
If col <= 21 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)
col = col + 4
Loop
idx = idx + 2
rw = rw + 2
Loop
End Sub
でも、rw = rw + 2 の記述があったのでよしとしましょうか！！
色は次投稿にて説明します
（ichinose） 2013/10/25(金) 06:08
では、色を付けることを考えます。現状、作図というプロシジャーは、四角形の色の指定は、できないので 出来るように変更しましょう。
'===============================================================================================================
Sub 作図(ByVal シート As Worksheet, ByVal 作成行 As Long, 到着便 As String, ByVal 到着時刻 As Date _
, ByVal 出発便 As String, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date, ByVal 作業終了時刻 As Date, 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 = 到着便 & " 到着 : " & Format(到着時刻, "hh:mm") & "／" & 出発便 & " 出発 : " & Format(出発時刻, "hh:mm")
'.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
作図というプロシジャーを上記のように変更してください。 これで四角形の色の指定ができるようになりました。前回投稿のmain2は、以下のようにすると、
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 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"))
idx = 11
rw = 3
Do Until idx > row1
Worksheets("sheet2").Cells(rw, 1).Value = sht.Cells(idx, 1).Value
col = 2
Do Until col > 41
If col <= 21 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, vbBlue)
col = col + 4
Loop
idx = idx + 2
rw = rw + 2
Loop
End Sub
今度は、青で四角形が作成されます。これを使って行毎色を変えて作図すればよいのですが・・・。
では、どのように行毎色をかえればよいのでしょうか？
色は、赤 青 マジェンタ、黄色、緑 で四角形をつくることとします。 この繰り返しで色の設定をします。
色を表すRGB値は、それぞれ 255、16711680、16711935、65535、65280
とこの数字の間に規則性など見つけられません！！
このような場合、規則性のある変数にいれて無理やり規則性を作る方法があります。
配列をつくります。
新規ブックの標準モジュールに
Sub hairetu_smp()
Dim carray As Variant
Dim g0 As Long
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
For g0 = 0 To 4
Range("a3").Interior.Color = carray(g0)
MsgBox carray(g0)
Next
End Sub
上記のコードはセルA3を赤 青 マジェンタ、黄色、緑の順序で順次塗りつぶしていくコードです。 表示される数字は、対象の色のRGB値です。
このように配列を利用すると、関連ないデータが、0～4の数値で規則性を持って取り出すことができます。
上記の例では
0 赤 1 青 2 マジェンタ 3 黄 4 緑
と数字と色のRGB値が対応するようになりました。
例では、セルを塗りつぶしましたが、図の四角形でも同じです。
では、赤 青 マジェンタ、黄色、緑の5色で繰り返し塗りつぶすのは、どのようにすれば よいでしょうか？
続きは、次投稿にて
（ichinose） 2013/10/25(金) 16:39
今、セルA1～A30まで 赤 青 マジェンタ、黄色、緑という色で塗りつぶしていくことを考えます。
A1からA5までなら簡単です。
Sub 色を塗りつぶす()
Dim carray As Variant
Dim rw As Long
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
rw = 1
Do Until rw > 5
Cells(rw, 1).Interior.Color = carray(rw - 1)
rw = rw + 1
Loop
End Sub
6行目以降は、又 配列carrayに対応する数字（添え字といいます）を0に戻すには？？？
このような場合、割り算の余りの数を利用すると簡単に実現ができます。
今回は、0～4の五つの数字の繰り返しですから、行を5で割った余りを利用します。
整数を5で割った余りは、必ず、0～4ですよね！！
余りの計算は MOD演算子を使うと計算してくれます。
すると・・・、
Sub 色を塗りつぶす()
Dim carray As Variant
Dim rw As Long
carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen)
rw = 1
Do Until rw > 30
Cells(rw, 1).Interior.Color = carray((rw - 1) Mod 5)
rw = rw + 1
Loop
End Sub
これでA1～A30が赤 青 マジェンタ、黄色、緑の順序の繰り返しで塗りつぶすことが出来ました。
では、本題に戻って・・・。
次投稿にて。
（ichinose） 2013/10/25(金) 17:02
本題に戻って、既投稿のmain2を見てみると・・・・、
作図開始行は、rw=3より rwの3で そこから、1行おきに作図していますよね
つまり、
3 5 7 9 11 13 15 ・・・・・と続くわけですが、
この行から0 1 2 3 4 0 1 2 3 4 を求めるには？
前回投稿のように きれいに 行が 1,2,3,4,5・・・と連続していないのですが、 何とか計算でできないかと 考えると・・・、
初期値が3ですから これを0にするためには 3を引いておけばよいですねえ
3-3は、0ですからね
次の5も 3を引くと 2です。これを1にするには、2で割れば 2/2 ＝1ですね
次の７は、 7-3＝4 これを2で割って 4/2＝2
これでいけそうですね！！ もうひとつ検算
(9-3)/2=3 もう完璧！！
(rw-3)/2 これで 0,1,2,3,4,5,6,7 と連続した値が得られます。
あとは、この値を5で割った余りを出せば、配列carrayの添え字がもとめられますねえ
それを プロシジャー作図のパラメータとして渡せば、色が5行毎に違った四角形が作図されます。
これをコード化してください。これで完成するはずです。
（ichinose） 2013/10/25(金) 17:52
ご教授ありがとうございます。
まずは、２段に分けて作図をするコードにつきましては、凄いです。確かに同じコードを２回も設定しなくても、こんなにすっきりできるとは・・・
本当に、ありがとうございました。又、とても勉強になりました。
さて、次の色についてですが、コードを変更しました。確かに青で作図されております。
これから、コード化に向けて、やってみます。
それから、お聞きしたい事が増えました。
まず、
1, sheet2の四角の図ですが、きちんと表示はされていますが、その場所以外に四角がギュっと凝縮されて表示されてしまいます。
場所は、sheet2のA行のグループ名が入る所の、セルAの一番左に四角の図と矢印が表示されます。一回全て任意に消しましたが、やはりまた出てしまいます。
2, Asheet2のチャート表で各グループ毎に罫線を引きましたが、マクロをスタートさせると罫線が全て消えます。これは仕方の無いことなのでしょうか？
(yuri)
１ について
>セルAの一番左に四角の図と矢印が表示されます 正しく四角形が作図されない時刻があるからだと思います。 その時刻が何回目なのか教えてください。 それと、各グループは、必ず、1回目から10回目までデータ（到着便名から作業終了時刻）があると 仮定してのプログラムです。
又は、作図されないグループの1回目から10回目のデータをすべて記述してください。
２について
mk_sample2を以下のように変更してください。プログラムで罫線も付けました。
'==================================================================
Sub mk_sample2()
Dim g0 As Long
Dim g1 As Long
With Worksheets("sheet2")
.Cells.Delete
.DrawingObjects.Delete
.Columns("a:a").ColumnWidth = 15
.Columns("b:dk").ColumnWidth = 5
g1 = 5
For g0 = 2 To 110 Step 6
With .Range(.Cells(1, g0), .Cells(1, g0 + 5))
.MergeCells = True
.Value = ((g1 - 1) Mod 24) + 1 & "時"
.HorizontalAlignment = xlCenter
With .Offset(1, 0).Resize(, 6)
.Value = Array(0, 10, 20, 30, 40, 50)
.HorizontalAlignment = xlLeft
.NumberFormat = "general"
End With
End With
g1 = g1 + 1
Next
With .Range("a1:a2")
.MergeCells = True
.HorizontalAlignment = xlCenter
.Value = "グループ名"
End With
.Rows("1:2").RowHeight = 13.5
With .Rows("3:60")
.RowHeight = 15
End With
With .Columns(1)
.Rows("3:4").MergeCells = True
.Rows("3:4").AutoFill Destination:=.Rows("3:62"), Type:=xlFillDefault
End With
With .Range("a1:dk62")
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
End With
End Sub
又、今回の問題とは関係ありませんが、以下ようにmain2 作図 というプログラムを変更してください。
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 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"))
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, vbBlue)
col = col + 4
Loop
idx = idx + 2
rw = rw + 2
Loop
End Sub
'===============================================================================================================
Sub 作図(ByVal シート As Worksheet, ByVal 作成行 As Long, 到着便 As String, ByVal 到着時刻 As Date _
, ByVal 出発便 As String, ByVal 出発時刻 As Date _
, ByVal 作業開始時刻 As Date, ByVal 作業終了時刻 As Date, 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 = 到着便 & " 到着 : " & Format(到着時刻, "hh:mm") & "／" & 出発便 & " 出発 : " & Format(出発時刻, "hh:mm")
.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
mk_sample2の実行で作成されたSheet2のレイアウトで main2を実行してみてください。
罫線は、私の方では、消えません（私の環境では もっとも罫線は、最初から消えていませんが）。
以上です。
（ichinose） 2013/10/26(土) 08:45
大変失礼しました。
1.の質問については
>各グループは、必ず、1回目から10回目までデータ（到着便名から作業終了時刻）があると仮定してのプログラムです。
確かに、sheet1のdataに空欄がある時にのみ発生してました。1から10回まで入ると消えます。
2.については
罫線をマクロで引くには、このようなコードになるんですね・・・
これも、私的にちょっと勉強して縦ライン(Vertical方向)をxlDotにしてみました。
できたら、なるほどって感動しています。
ほんとうに、コード変更して頂き、ありがとうございます。
最後の課題「色」は、難しくて悩んでいる所です。
(yuri)
>確かに、sheet1のdataに空欄がある時にのみ発生してました。1から10回まで入ると消えます。 実際のデータにも空欄があるのなら、それを意識したコードにする必要があるんですよ！！ 例えば、到着便名のセルが未入力だったら、 Call 作図（・・・）は、実行しないようにする とか 考えると方法はあると思いますよ！！
>最後の課題「色」は、難しくて悩んでいる所です。
色を分ける考え方は、説明したつもりです。
投稿を読んで、各コードを実行しその意味を調べ考えて頂き、 ここまでは、理解できる が、ここがわからない等のポイントを絞った記述をしてみてください。
yuriさんのこのスレッドの投稿が先月26日です。一ヶ月経ってしまいました。 最後、是非 ご自分で完成させてください。
（ichinose） 2013/10/26(土) 20:59
色々とお世話になります。
sheet1の入力表は毎日一回全部消して使用するので、今回全部消してみたら四角の図がsheet2の端に作図された事に気付きました。
実際には、sheet1のdataは全部埋まる事を考えていましたが、曜日によっては、各グループ2回位空欄ができる事がわかりました。
お手数ですが、到着便名が未入力の場合は、作図しない。ようにお願いしたいのですが？
又、色については、なんとか頑張ってみます。
１か月もご教授して頂き、感謝しています。
(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
このようになりました。OKでしょうか？
(yuri)
>このようになりました。OKでしょうか？ ＯＫですねえ！！
あと一つ、
>>実際のデータにも空欄があるのなら、それを意識したコードにする必要があるんですよ！！ >>例えば、到着便名のセルが未入力だったら、 Call 作図（・・・）は、実行しないようにする >>とか 考えると方法はあると思いますよ！！
>各グループ2回位空欄ができる事がわかりました。
では、何をみてその回が未入力とみなすか？ 上述したように、到着便名のセルが未入力だったら作図しないという仕様しましょう。
到着便名が設定されているセルの中身ってmain2のでは、 sht.Cells(idx, col).Value ですよね！！
では、この中身をチェックすればよいですよね？
If sht.Cells(idx, col).Value<>"" then call 作図（・・・）
です。
最後は、おまけっぽいけど、よいでしょう。
この仕上がったコードよく見直してください。
（ichinose） 2013/10/27(日) 16:41
1か月、ご教授して頂きありがとうございました。
最後のコードです。
If sht.Cells(idx, col).Value <> "" Then If 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))
これで、四角の図と矢印は消えました。
(yuri)
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
ここは、このようにすると、よいですね！！
If文もいくつかのパターンがありますから、よく調べてみてください。
全部のパターンがかなりの頻度で使われていますよ。
とにかく、これでおおよそ仕上がりましたね！！ あとは、よくテストしたり、アルゴリズムを確認してみてください
（ichinose） 2013/10/28(月) 07:02
コードの変更、ありがとうございます。
勉強になります。
>よくテストしたり、アルゴリズムを確認してみてください
はい。現在テスト中です。四角の中の文字を少し太くしたり、ちょっと変更しています。
あと、コードを再度確認し、理解できるよう勉強します。
(yuri)
元データはsheet4に入れました。
sheetの作りは
B C E G H J M N
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 下
行が5から84行 88行目から105行
同じように、
R S U W X Z AB AD
4 到着便名 出発便名 到着時刻 出発時刻 担当グループ名 作業開始時間 終了時間 表示
5 HHH便 III便 06:30 08:30 田中 06:40 07:40 上 6 JJJ便 KKK便 06:30 08:30 佐藤 06:40 07:40 上 7 LLL便 MMM便 06:30 08:30 吉田 06:40 07:40 上 8 NNN便 PPP便 06:30 08:30 田中 06:40 07:40 下
行が5～84行 このような作りになっています。
これをSheet1に転記したいと思っています。
?@基本的には、上から、つまりB～N側の5行～105行を、次にR～AD側の5行～84行を
sheet1の上から転記する。
?Aグループ名が同じ名前がある場合は、その作業は2回目の作業に転記される。3回同じ名前がある時は3回目の作業となります。
?BN列とAD列の「表示」ですが、「上」と入力した場合は1回目～5回目作業の所に転記され、「下」入れれば、6回目～10回目作業に転記される。
sheet1の作りです。
A | B C D E | F G ・
9 | 1回目作業 | 2回目作業
10 グループ名 | 到着便名 到着時刻 出発便名 出発時刻 |到着便名 到着時刻
11 第1グループ | AA便 07:30 BB便 09:00 |
12 | 作業時間 07:40 8:30 |
A | B C D E | F G ・
13 | 1回目作業 | 2回目作業
14 グループ名 | 到着便名 到着時刻 出発便名 出発時刻 |到着便名 到着時刻
15 第2グループ | CC便 06:30 DD便 08:00 |
16 | 作業時間 06:40 7:30 |
と、約30グループあります。
上手く説明が出来ていないかも知れません。又、マクロで何処まで可能かが、分かりませんが、ご教示のほどよろしくお願いいたします。
ichinose様には、お時間をさいて、ご教授して頂いたのに、真に申し訳ありません。
(yuri)
>別のsheetに入力してある内容を、このsheet1に入力していくには、かなり時間が掛かるので どなたかに そのように言われてのですか？
それはともかく、仕様の確認をしましょう！！
Sheet4のデータ ---> Sheet1に表を作成
Sheet1の表 ---> Sheet2にガントチャート作成 （既作）
Sheet1の表をビジュアル化したものがSheet2のガントチャートですよね？ そうなれば、同じ種類データをSheet1とSheet2に残す必要があるのか？ という疑問が出てきます。
Sheet4のデータ ---> Sheet2のガントチャート作成
でよいではないか？ ということです。いかがですか？？
Sheet4のデータですが・・・。
>行が5から84行 88行目から105行
↑この意味がはっきり把握できませんが、データを途中で折り返している ということですか？
表として、Ｂ列からＮ列にだけデータを入れていく というデータ形式では問題があるのですか？
VBAでプログラミングする場合、これらの表はテーブルと呼ばれるデータベースの単位になりますが、 これの構成は極力シンプルが鉄則です。
検討してみてください。
それとこのスレッド長くなってしまったので、スレッドを新しくして 「１日の作業工程をガントチャート表示にしたい2」とでもして、新規にスレッドを立ち上げてみたらどうですか？
その際は、このスレッドとの相互リンクを行ってください。
（ichinose@これから山菜採り） 2013/11/09(土) 09:24
お世話になります。
>別のsheetに入力してある内容を、このsheet1に入力していくには、かなり時間が掛かるので どなたかに そのように言われてのですか？ ・はい。実は、会社で私を含め8人この表を扱いまして、今まではそのsheet4のデータを基に、作業工程をホワイトボードに線を書いていました。で私の提案で、ホワイトボード式を止めパソコン管理はできないものか？で始まりました。 しかし、sheet4をsheet1にガントチャート用として入力するのに、以外に時間か掛かるとの声が、ありまして・・・
>行と列につきましては、変更可能です。
>Sheet4のデータ ---> Sheet2のガントチャート作成 はい。できれば、その方が、良いです。
これからsheet4の表を少し変更して、新スレッドで立ち上げます。 (yuri)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.