[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルを塗りつぶしてグラフを作りたい』(ふみ)
工数の負荷状況をリアルタイムに知る為に、いろいろな件名の各工程の費用と期間を
入力すると、時間単価で割って1日当たりの工数を産出し、その工数だけセルを
塗りつぶしてグラフ化し、件名が増える毎に色を変えたセルの塗りつぶしが
累積されて、日々の負荷がわかる様にしたいです。
例えば件名が2件あって、件名1:設計開始8月1日、終了8月31日、費用3百万円、
組立開始8月20日、終了9月15日、費用1.5百万円、
件名2:設計開始7月20日、終了8月10日、費用2百万円、組立開始7月30日、終了8月20日、費用1.2百万円、
と期間と費用を入力すると、カレンダーの開始日が一番早い7月20日に変わって、
それぞれの費用を工事期間で割って時間単価で割った工数分のセルがその期間の間、
均等に塗りつぶされて、件名1と件名2の工数が色分けされていて、どの日付の工数が多いのかひと目でわかる様にしたいです。
工数を産出したりカレンダーの開始日を変更してカレンダーを書き換える事は出来ると
思うのですが、工数分セルを塗りつぶす、増えていく件名を追加入力した時の累積の
させ方がわかりません。御指導下さい。
< 使用 Excel:Excel2007、使用 OS:Windows7 >
提示された情報だけでは、ほぼまっさらな所から全ての機能を作る様なものだと思いますので 回答も躊躇してしまうかなと。 という事で参考情報程度の回答ですが 工程管理 Excel なんてキーワードでGoogle検索すると求める物に近い機能を持つものが 見つかるかもしれません? (ご近所PG) 2015/08/11(火) 15:07
情報を更新・追加するのは自由に行い、処理用にボタンを置き、これを押した際にマクロ動作。
マクロでは入力情報全てチェックし、日付に応じて塗りつぶしを行う、という感じになるかと思います。
追加分だけ描画、というのは、情報の更新(日付変更)が行われた際の処理が面倒です。
なので、毎回出力領域を全て消して、全データ分描画してしまう方が良いでしょう。
(???) 2015/08/11(火) 17:11
???さん、アドバイスありがとう御座います。
確かにボタンをトリガーにして全て更新の方が考えやすいです。
まだまだ時間がかかりそうですが、考えてみます。
ありがとう御座いました。
(ふみ) 2015/08/20(木) 10:26
'シート名「データ」、「表」の二つを準備 '▼▼▼▼▼ 'シート「データ」の構成・・・1行目は表題、2行目からデータ入力 '1行目:A1[件名] B1[設計開始] C1[設計終了] D1[設計費用] E1[組立開始] F1[組立終了] G1[組立費用] '2行目:件名1 2015/8/1 2015/8/31 3000000 2015/8/20 2015/9/15 1500000 '3行目:件名2 2015/7/21 2015/7/30 2000000 2015/7/30 2015/8/20 1200000 '4行目:件名3 2015/7/25 2015/7/29 500000 2015/8/5 2015/8/25 1000000 '5行目:件名4 2015/7/26 2015/8/15 1500000 2015/8/5 2015/8/25 1000000 '▲▲▲▲▲ '▼▼▼▼▼ 'シート「表」 '記入不要。グラフ書き出し用 '▲▲▲▲▲
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Target As Range, j As Integer
With Sheets("表") .Cells.ClearContents .Cells.ClearFormats End With
With Sheets("データ") Set Rng1 = .UsedRange Set Rng2 = .Range("B2:C" & Rows.Count) Set Rng3 = .Range("E2:F" & Rows.Count) Set Target = Intersect(Rng1, Union(Rng2, Rng3)) Do Sheets("表").Cells(1, j + 1) = DateValue(Format(Application.Min(Target), "yyyy/mm/dd")) + j If Sheets("表").Cells(1, j + 1) >= DateValue(Format(Application.Max(Target), "yyyy/mm/dd")) Then Exit Do j = j + 1 Loop
For Each cl In Intersect(.UsedRange, .Range("A2:A" & Rows.Count)) If .Cells(cl.Row, 1) <> "" Then sub1 .Cells(cl.Row, 2), .Cells(cl.Row, 3), .Cells(cl.Row, 4).Value / (1 + (.Cells(cl.Row, 3) - .Cells(cl.Row, 2))), .Cells(cl.Row, 1) & "設計", cl.Row sub1 .Cells(cl.Row, 5), .Cells(cl.Row, 6), .Cells(cl.Row, 7).Value / (1 + (.Cells(cl.Row, 6) - .Cells(cl.Row, 5))), .Cells(cl.Row, 1) & "組立", cl.Row End If Next cl End With
End Sub
Sub sub1(arg1 As Date, arg2 As Date, arg3 As Long, arg4 As String, arg5 As Integer) '開始日付,終了日付,塗りつぶす行数(1万円=1行),件名,colorindex
Dim i As Integer, j As Integer, s_row As Long, e_row As Long
arg3 = Application.RoundUp(arg3 / 10000, 0)
With Sheets("表") Do While .Cells(1, j + 1) <> "" If (.Cells(1, j + 1) >= arg1) And (.Cells(1, j + 1) <= arg2) Then s_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + 1 e_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + arg3 For i = s_row To e_row .Cells(i, j + 1) = arg4 .Cells(i, j + 1).Interior.ColorIndex = arg5 + 1 Next i End If j = j + 1 Loop End With
End Sub
(mm) 2015/08/20(木) 15:10
(ふみ) 2015/08/20(木) 15:47
Sub main()
'シート名「データ」、「設計」、「組立調整」の三つを準備 '▼▼▼▼▼ 'シート「データ」の構成・・・1行目は表題、2行目からデータ入力 '1行目:A1[件名] B1[設計開始] C1[設計終了] D1[設計費用] E1[組立開始] F1[組立終了] G1[組立費用] '2行目:件名1 2015/8/1 2015/8/31 3000000 2015/8/20 2015/9/15 1500000 '3行目:件名2 2015/7/21 2015/7/30 2000000 2015/7/30 2015/8/20 1200000 '4行目:件名3 2015/7/25 2015/7/29 500000 2015/8/5 2015/8/25 1000000 '5行目:件名4 2015/7/26 2015/8/15 1500000 2015/8/5 2015/8/25 1000000 '▲▲▲▲▲ '▼▼▼▼▼ 'シート「設計」「組立調整」 '記入不要。グラフ書き出し用 '▲▲▲▲▲
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Target1 As Range, Target2 As Range, j As Integer, k As Integer, cl As Range
With Sheets("設計") .Cells.ClearContents .Cells.ClearFormats End With
With Sheets("組立調整") .Cells.ClearContents .Cells.ClearFormats End With
With Sheets("データ") Set Rng1 = .UsedRange Set Rng2 = .Range("B2:C" & Rows.Count) Set Rng3 = .Range("E2:F" & Rows.Count) Set Target1 = Intersect(Rng1, Rng2) Set Target2 = Intersect(Rng1, Rng3) Do Sheets("設計").Cells(1, j + 1) = DateValue(Format(Application.Min(Target1), "yyyy/mm/dd")) + j If Sheets("設計").Cells(1, j + 1) >= DateValue(Format(Application.Max(Target1), "yyyy/mm/dd")) Then Exit Do j = j + 1 Loop
Do Sheets("組立調整").Cells(1, k + 1) = DateValue(Format(Application.Min(Target2), "yyyy/mm/dd")) + k If Sheets("組立調整").Cells(1, k + 1) >= DateValue(Format(Application.Max(Target2), "yyyy/mm/dd")) Then Exit Do k = k + 1 Loop
For Each cl In Intersect(.UsedRange, .Range("A2:A" & Rows.Count)) If .Cells(cl.Row, 1) <> "" Then sub1 .Cells(cl.Row, 2), .Cells(cl.Row, 3), .Cells(cl.Row, 4).Value / (1 + (.Cells(cl.Row, 3) - .Cells(cl.Row, 2))), .Cells(cl.Row, 1) & "設計", cl.Row sub2 .Cells(cl.Row, 5), .Cells(cl.Row, 6), .Cells(cl.Row, 7).Value / (1 + (.Cells(cl.Row, 6) - .Cells(cl.Row, 5))), .Cells(cl.Row, 1) & "組立", cl.Row End If Next cl End With
End Sub
Sub sub1(arg1 As Date, arg2 As Date, arg3 As Long, arg4 As String, arg5 As Integer) '開始日付,終了日付,塗りつぶす行数(1万円=1行),件名,colorindex
Dim i As Integer, j As Integer, s_row As Long, e_row As Long
arg3 = Application.RoundUp(arg3 / 10000, 0)
With Sheets("設計") Do While .Cells(1, j + 1) <> "" If (.Cells(1, j + 1) >= arg1) And (.Cells(1, j + 1) <= arg2) Then s_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + 1 e_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + arg3 For i = s_row To e_row .Cells(i, j + 1) = arg4 .Cells(i, j + 1).Interior.ColorIndex = arg5 + 1 Next i End If j = j + 1 Loop End With
End Sub
Sub sub2(arg1 As Date, arg2 As Date, arg3 As Long, arg4 As String, arg5 As Integer) '開始日付,終了日付,塗りつぶす行数(1万円=1行),件名,colorindex
Dim i As Integer, j As Integer, s_row As Long, e_row As Long
arg3 = Application.RoundUp(arg3 / 10000, 0)
With Sheets("組立調整") Do While .Cells(1, j + 1) <> "" If (.Cells(1, j + 1) >= arg1) And (.Cells(1, j + 1) <= arg2) Then s_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + 1 e_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + arg3 For i = s_row To e_row .Cells(i, j + 1) = arg4 .Cells(i, j + 1).Interior.ColorIndex = arg5 + 1 Next i End If j = j + 1 Loop End With
End Sub
(ふみ) 2015/08/21(金) 11:40
塗りつぶし方の案を2つ。
(1)開始日〜末日を1日ずつ休日判定し、平日のみ塗る案。
(2)まずは末日まで現状と同じように塗ってしまった後、休日の列ならば塗りつぶしを消してしまう案。
(???) 2015/08/21(金) 12:59
ただ、金額を期間で均等に割って1日当たりの金額を塗りつぶすのですが、
土日と祝日を除いた期間(日数)で金額を割らないといけません。
そこはどうしたら良いでしょうか?
よろしくお願いします。
(ふみ) 2015/08/21(金) 15:06
'シート名「データ」、「設計」、「組立調整」の三つを準備 '▼▼▼▼▼ 'シート「データ」の構成・・・1行目は表題、2行目からデータ入力 '1行目:A1[件名] B1[設計開始] C1[設計終了] D1[設計費用] E1[組立開始] F1[組立終了] G1[組立費用] '2行目:件名1 2015/8/1 2015/8/31 3000000 2015/8/20 2015/9/15 1500000 '3行目:件名2 2015/7/21 2015/7/30 2000000 2015/7/30 2015/8/20 1200000 '4行目:件名3 2015/7/25 2015/7/29 500000 2015/8/5 2015/8/25 1000000 '5行目:件名4 2015/7/26 2015/8/15 1500000 2015/8/5 2015/8/25 1000000 '▲▲▲▲▲ '▼▼▼▼▼ 'シート「設計」「組立調整」 '記入不要。グラフ書き出し用 '▲▲▲▲▲
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Target1 As Range, Target2 As Range, j As Integer, k As Integer, cl As Range
With Sheets("設計") .Cells.ClearContents .Cells.ClearFormats End With
With Sheets("組立調整") .Cells.ClearContents .Cells.ClearFormats End With
With Sheets("データ")
Set Rng1 = .UsedRange Set Rng2 = .Range("B2:C" & Rows.Count) Set Rng3 = .Range("E2:F" & Rows.Count) Set Target1 = Intersect(Rng1, Rng2) Set Target2 = Intersect(Rng1, Rng3)
Do Sheets("設計").Cells(1, j + 1) = DateValue(Format(Application.Min(Target1), "yyyy/mm/dd")) + j If Sheets("設計").Cells(1, j + 1) >= DateValue(Format(Application.Max(Target1), "yyyy/mm/dd")) Then Exit Do j = j + 1 Loop
Do Sheets("組立調整").Cells(1, k + 1) = DateValue(Format(Application.Min(Target2), "yyyy/mm/dd")) + k If Sheets("組立調整").Cells(1, k + 1) >= DateValue(Format(Application.Max(Target2), "yyyy/mm/dd")) Then Exit Do k = k + 1 Loop
For Each cl In Intersect(.UsedRange, .Range("A2:A" & Rows.Count)) If .Cells(cl.Row, 1) <> "" Then sub1 .Cells(cl.Row, 2), .Cells(cl.Row, 3), .Cells(cl.Row, 4).Value / (1 - HolidayCount(.Cells(cl.Row, 2), .Cells(cl.Row, 3)) + (.Cells(cl.Row, 3) - .Cells(cl.Row, 2))), .Cells(cl.Row, 1) & "設計", cl.Row, "設計" sub1 .Cells(cl.Row, 5), .Cells(cl.Row, 6), .Cells(cl.Row, 7).Value / (1 - HolidayCount(.Cells(cl.Row, 5), .Cells(cl.Row, 6)) + (.Cells(cl.Row, 6) - .Cells(cl.Row, 5))), .Cells(cl.Row, 1) & "組立", cl.Row, "組立調整" End If Next cl End With
End Sub
Sub sub1(arg1 As Date, arg2 As Date, arg3 As Long, arg4 As String, arg5 As Integer, arg6 As String) '開始日付,終了日付,塗りつぶす行数(1万円=1行),件名,colorindex,シート名
Dim i As Long, j As Long, s_row As Long, e_row As Long
arg3 = Application.RoundUp(arg3 / 10000, 0)
With Sheets(arg6) Do While .Cells(1, j + 1) <> "" If (.Cells(1, j + 1) >= arg1) And (.Cells(1, j + 1) <= arg2) And (HolidayJudge(.Cells(1, j + 1)) = False) Then s_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + 1 e_row = .Cells(Rows.Count, j + 1).End(xlUp).Row + arg3 For i = s_row To e_row .Cells(i, j + 1) = arg4 .Cells(i, j + 1).Interior.ColorIndex = arg5 + 1 Next i End If j = j + 1 Loop End With
End Sub
Function HolidayCount(arg1 As Date, arg2 As Date) As Integer 'arg1とarg2の期間の土・日・祝日
Dim hdy As Date, hdyctr As Long For hdy = arg1 To arg2 If (Weekday(hdy) = 1) Or (Weekday(hdy) = 7) Then hdyctr = hdyctr + 1 Else If HolidayJudge_2(hdy) = True Then hdyctr = hdyctr + 1 End If Next hdy HolidayCount = hdyctr End Function
Function HolidayJudge(arg1 As Date) As Boolean '土・日ならtrue
If (Weekday(arg1) = 1) Or (Weekday(arg1) = 7) Then HolidayJudge = True If HolidayJudge_2(arg1) = True Then HolidayJudge = True End Function
Function HolidayJudge_2(arg1 As Date) As Boolean '祝日ならtrue
For i = 0 To UBound(Split(Holidayarray, ",")) If arg1 = DateValue(Split(Holidayarray, ",")(i)) Then HolidayJudge_2 = True: Exit Function Next i End Function
(mm) 2015/08/21(金) 15:43
本当にありがとう御座いました。
(ふみ) 2015/08/21(金) 16:55
.Cells(i, j + 1).Interior.ColorIndex = arg5 + 1
のところで4番目の色を指定しているのは、
どこのコードをみれば良いのでしょうか?
同じ様にコードを書くと、1番目の黒色になってしまい、
しかも+1にならず、全て黒色になってしまいます。
よろしくお願いします。
(ふみ) 2015/08/26(水) 13:30
黒になるということは、ColorIndex =1 を指定しているわけであり、すると arg5 は 0 なのでは?
このプロシジャを呼び出している側を確認しましょう。
(mainで、.Cells(cl.Row, 1) を指定ですか? A列はちゃんと入力されていますか?)
(???) 2015/08/26(水) 14:19
(ふみ) 2015/08/26(水) 14:56
Sub ○○( ) ~~~ ↑ ここのかっこの中にいれるモノについて調べてください F8で1行ずつ実行し、コードの流れをみてください (なんならコードを印刷して実行順序を行ごとにかきこんでみてください) その際、ローカルウィンドウやウォッチ式の追加で変数がどうなっているか追ってください (ローカルウィンドウやウォッチ式の追加方法は調べてください。役立ちます!)
それを行ったうえで、以下のとおりにコードを追ってみてください どこで指定しているのかわからない場合は、逆にたどります
今回のColorIndexについては、sub1のコードの .Cells(i, j + 1).Interior.ColorIndex = arg5 + 1 つまり、arg5 + 1で指定していますよね
arg5はsub1のかっこの中(arg1 As Date, arg2 As Date, arg3 As Long, arg4 As String, arg5 As Integer, arg6 As String) arg5 As Integer(5番目の引数)ですね。 その横に親切にコメントがついています 開始日付,終了日付,塗りつぶす行数(1万円=1行),件名,colorindex,シート名 (5番目の引数)はcolorindexですね
で、実際にsub1を実行するように指定しているmainを見ます sub1 .Cells(cl.Row, 2), 〜略〜 ,cl.Row, "設計" (5番目の引数)はcl.Row ですね clの行数をもとにColorIndexを指定していることがわかりました
(コードの確認を) 2015/08/26(水) 16:06
sub1 .Cells(cl.Row, 2), 〜略〜 ,cl.Row, "設計" のコードが理解出来ていなくて、ちゃんと調べなくて、 arg1からarg6までの変数をどこで指定しているのかわかりませんでした。
というか、subコードとmainコードの繋ぎ方がちゃんと理解出来ていませんね。
デバッグもF8でやっていたのですが、なぜかデバッグすると
途中でエラーになり、追う事が出来ませんでした。
勉強不足で申し訳有りませんが、理解出来てスッキリしました。
ありがとう御座いました。
(ふみ) 2015/08/26(水) 16:43
Function HolidayJudge_2(arg1 As Date) As Boolean '祝日ならtrue
Dim k As Long, j As Long, Holidayarray As String, C As Variant
C = Sheets("データ").Range("L3:M100") For k = 1 To 100 For j = 1 To 2 Holidayarray = C(k, j) Next j Next k
Dim i As Long
For i = 0 To UBound(Split(Holidayarray, ",")) If arg1 = DateValue(Split(Holidayarray, ",")(i)) Then HolidayJudge_2 = True: Exit Function Next i End Function
これだと”インデックスが有効範囲にありません”というエラーになります。
(ふみ) 2015/08/27(木) 14:19
Dim fcell As Range, frange As Range Set frange = Sheets("データ").Range("L3:M100") frange.NumberFormatLocal = "yyyy/m/d;@" Set fcell = frange.Find(What:=Format(arg1, "yyyy/m/d"), LookIn:=xlValues, LookAt:=xlWhole) If fcell Is Nothing Then Else HolidayJudge_2 = True End If End Function (mm) 2015/08/27(木) 15:42
書いて頂いたコードに変えてみましたが、
frange.NumberFormatLocal = "yyyy/m/d;@"
のところで「RangeクラスのNumberFormatLocalプロパティを設定できません。」
というエラーが出ます。
;と@と両方共と消して試してみましたが同じでした。
(ふみ) 2015/08/27(木) 16:05
mmさんのコードは凄すぎて理解出来ませんが、
一生懸命勉強して理解出来る様にします。
本当にありがとう御座います。
(ふみ) 2015/08/27(木) 16:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.