[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロ コードの変更について』(yuri)
以前にお世話になりましたyuriと申します。前回はichinose様に大変お世話になりガントチャートのコードを作成して頂き、使用していましたが、今回は、コードの変更で悩んでいます。 大きな変更点は、時間を5時を6時からにして、チャート表示を2列目を7列目から開始に変更したいのですが、私が変更したコードだと、1時間遅れて表示されてしまいます。 あと、何処を変更したらよいのか、ご教授下さい。 以前のコード[[20131109131120]]
今回変更中のコード
Sub mk_表の作成() Dim g1 As Long Dim g2 As Long With Worksheets("チャート表") .Cells.Delete .DrawingObjects.Delete .Columns("a").ColumnWidth = 8 .Columns("b").ColumnWidth = 12 .Columns("c:f").ColumnWidth = 5 .Columns("g:cl").ColumnWidth = 4
g2 = 6 For g1 = 7 To 121 Step 6 With .Range(.Cells(4, g1), .Cells(4, g1 + 5)) .MergeCells = True .Value = ((g2 - 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 g2 = g2 + 1
Next With .Range("a4:a5") 'a2:a3セルに責任者と入れる .MergeCells = True .HorizontalAlignment = xlCenter '文字はCTRに .Value = "責任者" End With With .Range("b4:b5") .MergeCells = True .HorizontalAlignment = xlCenter .Value = "課-係" End With With .Range("c4:d5") .MergeCells = True .HorizontalAlignment = xlCenter .Value = "勤務コード" End With
With .Range("e4:e5") .MergeCells = True .HorizontalAlignment = xlCenter .Value = "人員" End With
With .Range("f4:f5") .MergeCells = True .HorizontalAlignment = xlCenter .Value = "無線" End With
.Rows("4:5").RowHeight = 20 With .Rows("6:99") .RowHeight = 50 End With
With .Columns(1) .Rows("6:7").MergeCells = True .Rows("6:7").AutoFill Destination:=.Rows("6:99"), Type:=xlFillDefault End With
With .Columns(2) .Rows("6:7").MergeCells = True .Rows("6:7").AutoFill Destination:=.Rows("6:99"), Type:=xlFillDefault
End With
With .Range("g4:dq99") With .Borders .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin
End With .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone
End With With .Range("g6:dq99") With .Borders(xlInsideVertical) .LineStyle = xlDot .Weight = xlHairline
End With End With End With
End Sub
Sub 新ガントチャート() Const ss = 7 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("進捗管理") With sht row1 = .Cells(.Rows.Count, "i").End(xlUp).Row End With With Worksheets("チャート表") On Error Resume Next .DrawingObjects.Delete .Columns("a:a").ClearContents .Range("a4").Value = "グループ名" On Error GoTo 0 .Columns("a").ColumnWidth = 10 .Columns("b").ColumnWidth = 12 .Columns("c:f").ColumnWidth = 5 .Columns("g:dq").ColumnWidth = 4
For idx = 1 To ss - 1 sumwidth = sumwidth + .Columns(idx).ColumnWidth Next hh = .Range("g:g").ColumnWidth End With Call open_scale(ss, sumwidth, hh, Worksheets("チャート表")) carray = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbGreen) idx = 5 'sheet4のデータ読み込み開始行をidxに設定(開始行5行目) rw = 6 '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("チャート表").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("チャート表"), 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のデータ読み込み行を1つ増やす Loop Set dic = Nothing End Sub
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 = 120, Optional ByVal sht As Worksheet = Nothing) As Shape '指定された行に開始位置,巾の情報から、チャート(ライン)を作成する 'input : rng---作成する行を表すRangeオブジェクト ' 開始---チャート作成開始位置を開始列からの列幅単位で指定 ' 巾-----チャート作成巾を列幅単位で指定 ' t_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
以上のコードです。よろしくお願いします。
< 使用 Excel:Excel2007、使用 OS:Windows8 >
>1時間遅れて表示されてしまいます。 提示されていませんけど、作図2というプロシジャーがありましたよね?
この中に TimeSerial(5, 0, 0) と記述された箇所がいくつかあると思います。 この意味を調べてみてください。5時から6時に変更ですよね?
何となくわかりますでしょ?
それから・・・・。
レイアウトは、mk_表の作成というプロシジャーを実行すれば、レイアウトが作成されるので これの提示は、非常によかったですねえ。簡単に出力イメージが作成されますからねえ。
又、前スレッドをリンクされたのも良いです。
でも、リンク先は 非常に長いですよね!! 詳細は、これ見てね では、誰も見ませんよ!! 少なくとも私なら見ません。
このスレッドで 入力データ例と
このコードを実行すると、「ほら、一時間ずれてしまいます」をきちんとコードで閲覧者を 「あっ、本当だ」と納得させる記述を心がけてください。 そういう記述がプログラミングには必ず役に立ちますから・・・。
(ichinose@今日も暑かった) 2014/08/01(金) 18:30
ichinose様
返事が遅くなりすみません。
またまたお世話になります。
TimeSerial(5, 0, 0)を(6,0,0)に変更してokとなりました。
勉強不足でした。
記述方法も、気を付けたいと思います。
有難うございました。
(yuri)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.