[[20140731203330]] 『マクロ コードの変更について』(yuri) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『マクロ コードの変更について』(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.