[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロ コードの変更について』（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のデータ読み込み行を１つ増やす
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オブジェクト
' 開始---チャート作成開始位置を開始列からの列幅単位で指定
' 巾-----チャート作成巾を列幅単位で指定
' ｔ_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.