[[20150811135300]] 『セルを塗りつぶしてグラフを作りたい』(ふみ) ページの最後に飛ぶ

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

 

『セルを塗りつぶしてグラフを作りたい』(ふみ)

工数の負荷状況をリアルタイムに知る為に、いろいろな件名の各工程の費用と期間を
入力すると、時間単価で割って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


ご近所PGさん、ありがとう御座います。
工程管理 エクセルで検索してみたら、色々なサンプルシートが
出ていました。

???さん、アドバイスありがとう御座います。
確かにボタンをトリガーにして全て更新の方が考えやすいです。
まだまだ時間がかかりそうですが、考えてみます。

ありがとう御座いました。
(ふみ) 2015/08/20(木) 10:26


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, 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


mmさん、ありがとう御座います。
書いて頂いたコードを走らせてみたら、イメージに近いものが出来ていました。
このコードを基本にして、自分が作りたい完成形にしていきたいと思います。
また、わからなくなったら教えて下さい。
本当に、ありがとう御座いました。

(ふみ) 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


まず、土日と祝日を除く場合、WorksheetFunction.WorkDayを使うと良いでしょう。調べてみて下さい。

塗りつぶし方の案を2つ。
(1)開始日〜末日を1日ずつ休日判定し、平日のみ塗る案。
(2)まずは末日まで現状と同じように塗ってしまった後、休日の列ならば塗りつぶしを消してしまう案。
(???) 2015/08/21(金) 12:59


???さん
コメントありがとう御座います。
土日と祝日の列を除く方法としては(2)で考えられそうな気がします。

ただ、金額を期間で均等に割って1日当たりの金額を塗りつぶすのですが、
土日と祝日を除いた期間(日数)で金額を割らないといけません。
そこはどうしたら良いでしょうか?

よろしくお願いします。

(ふみ) 2015/08/21(金) 15:06


Const Holidayarray = "2015/7/20,2015/9/21,2015/9/22,2015/9/23" '祝日をカンマ区切りで文字列化
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 - 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


mmさん、本当にありがとう御座います。
土、日を削除するのではなく、塗らない様にしたいな、と思っていたのですが、
その通りになっていて感激です。
また祝日も記入出来て完璧だと思います。
まるまるコードを書いて頂いて申し訳ない気持ちで一杯ですが、
このコードを最初に理解して、これをベースに細かい事を色々追加して
完成形に持って行こうと思います。

本当にありがとう御座いました。
(ふみ) 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


ここに書かれているコードを実行すると、
ColorIndexは順番に4,5,6,7となりますが、
どこのコードで最初に3(4=3+1)を指定しているかが
わからないから質問しています。
mainの方で指定しているのであれば、そのコードの箇所を教えて下さい。

(ふみ) 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


度々申し訳有りません。
祝日を、
Const Holidayarray = "2015/7/20,2015/9/21,2015/9/22,2015/9/23" '祝日をカンマ区切りで文字列化
でコードの中に書き込む様にして頂いていますが、
Sheets(データ)の例えばRange("L3:M100")のセルに祝日を書き込んで、
読みにいく様に変更したくて色々調べてやっていますが、うまくいきません。

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


Function HolidayJudge_2(arg1 As Date) As Boolean '祝日ならtrue
    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

mmさん、ありがとう御座います。

書いて頂いたコードに変えてみましたが、

frange.NumberFormatLocal = "yyyy/m/d;@"

のところで「RangeクラスのNumberFormatLocalプロパティを設定できません。」

というエラーが出ます。

;と@と両方共と消して試してみましたが同じでした。
(ふみ) 2015/08/27(木) 16:05


シート保護されていませんか?
(mm) 2015/08/27(木) 16:27

mmさん、申し訳有りません。走りました。
シート保護していまして、
Sheets(データ)の方のコードにはUnprotect Passwordを入れていたのですが、
Moduleの方のコードに入れていませんでした。

mmさんのコードは凄すぎて理解出来ませんが、
一生懸命勉強して理解出来る様にします。

本当にありがとう御座います。
(ふみ) 2015/08/27(木) 16:48


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.