Results of 1 - 1 of about 13 for 色 個数 条件付書式 (0.004 sec.)
色 (1056), 個数 (3529), 条件付書式 (2647)
- [[20120314194032]]
- #score: 11877
- @digest: 5627c0a4b5a8ad9df49bee97b9d41f08
- @id: 58126
- @mdate: 2012-03-15T09:36:55Z
- @size: 19237
- @type: text/plain
- #keywords: lngindex (72296), lngpos (67846), lngcount (65573), breakr2 (59046), breakr1 (59046), breakr3 (58145), timeconv (57279), vntreste (56447), cdblstart (49391), 工数 (45427), breakr (44285), vntrests (36904), vntover (36340), stc (27247), ル先 (24405), ウリ (24264), ャベ (23281), ベツ (22241), mybar (21337), vntdata (16454), 付セ (15642), 付数 (14222), ュウ (13488), 憩時 (10815), 休憩 (10405), 色付 (10144), オレ (8025), ル分 (7432), interior (7350), 分( (7143), lngrows (7099), 間帯 (6709)
- 『セルの塗りつぶし』（FA）
いつもお世話になっております。 ご指導をお願いしたくご質問させて頂きます。 下記のような表があります。 【表】 A B C D E F G H I J K L M N O ・・・・・ 1 2012/3/14 野菜 8 9 ・・・・・ 2 製品名 個数 工数 10 20 30 40 50 60 10 20 30 40 50 60 ・・・・・ 3 トマト 1000 40 4 キャベツ 2000 323 5 キュウリ 300 100 6 レタス 400 200 7 8 2012/3/14 果物 8 9 9 製品名 個数 工数 10 20 30 40 50 60 10 20 30 40 50 60 ・・・・・ 10 メロン 2000 122 11 オレンジ 300 30 12 バナナ 1500 751 この表は工数表です。1時間を10分毎に分けています。1セル=10分。横軸は朝8時〜夜の22時まで続きます。工数の単位は分です。 休憩の時間は予め色を塗りつぶしてあります。休憩時間は12:00〜13:00、15:00〜15:10、17:00〜17:30です。 製品名の数は毎日変わります。 行の1及び2は予め黄色に塗りつぶしています。行の8及び9(製品数によって変わる)も黄色に塗ってあります。 野菜と果物のグループの間は1行空いています。グループは他にもあり下に続いています。最大15グループです。 やりたいこと】 各製品の工数分のセルを横にオレンジ色で塗りつぶしたい。 【例】 製品名:トマト 工数:40 工数が40分なので、4セル分(8:00〜8:40まで)塗りつぶします。 次の、製品名:キャベツ 工数:323 は 工数が323分なので、33セル分(8:40〜15:20まで)塗りつぶします。※1の位は繰り上げます。 ※12:00〜13:00までと15:00〜15:10まで休憩が入るので、休憩部分は飛ばして塗りつぶします。 次の、製品名:キュウリ 工数:100 は 工数が100分なので、10セル分(15:20〜17:00) 次の、製品名:レタス 工数:200 は 工数が200分なので、20セル分(17:30〜20:50) 17:00〜17:30は休憩なので休憩部分は飛ばして17:30から塗りつぶします。 しかし就業時間が20:00なので、20:00以降は赤色で塗りつぶします。 他のグループも同様です。 どうかご指導お願い致します。 【バージョン】 Windows7 Excel2007 ---- >製品名:キャベツ 工数:323 は 工数が323分なので、33セル分(8:40〜15:20まで)塗りつぶします >次の、製品名:キュウリ 工数:100 は 工数が100分なので、10セル分(15:20〜17:00) 15:20セルはキャベツ作業セルだよね。で、キャベツ作業中にキュウリを並行作業するの? で、これを関数で?VBAで? 関数では色書式の変更はできないのでVBAなのかな? （無理やりやれば条件付書式なんかでできるかもしれないけど、非現実的だと思う） 追記）作業量は工数だけで判断するんだね。個数は、あくまで参考項目だね。 (ぶらっと) ---- >12 バナナ 1500 751 は、工数が作業時間をオーバーしますよね? この場合は如何するの? (Bun) ---- ぶらっと様 お世話になります。ご説明不足で大変申し訳ありません! ＞15:20セルはキャベツ作業セルだよね。で、キャベツ作業中にキュウリを並行作業するの? 1グループ内で並行作業は行いません。 トマトが終わったらキャベツ、キャベツが終わったらキュウリと、1製品ごとに流していきます。 トマトはトマト行のセル、キャベツはキャベツ行のセルとなります。 ＞で、これを関数で?VBAで? 当初、ぶらっと様が仰るように条件書式などで考えていましたが、関数式などで悩み断念致しました。 今はVBAじゃないと駄目かな?と思っています。 ＞追記）作業量は工数だけで判断するんだね。個数は、あくまで参考項目だね。 作業量は工数だけで判断致します。仰る通り個数は参考項目となります。 Bun様 大変ご無沙汰しております!またご教授お願います。 ＞ は、工数が作業時間をオーバーしますよね? ＞この場合は如何するの? オーバーした場合、工程管理者が生産工数を減らし時間内に収まるように工数を調整致します。 (FA) ---- もっと簡単に成りそうな気がして余り気に入らないのですが? 叩き台くらいに成れば善いのですが? 尚、工数がオーバーした場合は時間外の1セルが余計に色が付きます Option Explicit Public Sub Sample() 'Listの中の「工数」と成る列位置(基準列を0列目として:2列目) Const clngMan As Long = 2 '通常のColor Const clngColor1 As Long = 49407 '残業時のColor Const clngColor2 As Long = 255 '作業開始時間 Const cdblStart As Double = #8:00:00 AM# '作業終了時間 Const cdblEnd As Double = #10:00:00 PM# Dim i As Long Dim j As Long Dim k As Long Dim lngRows As Long Dim lngPos As Long Dim rngList As Range Dim rngResult As Range Dim vntData As Variant Dim vntRestS As Variant Dim vntRestE As Variant Dim vntOver As Variant Dim lngIndex() As Long Dim lngCount As Long Dim strProm As String 'Listの先頭セル位置を基準とする（先頭列の「2012/3/14」のセル位置） Set rngList = Worksheets("Sheet1").Range("A1") '休憩時間 vntRestS = Array(#12:00:00 PM#, #3:00:00 PM#, #5:00:00 PM#) vntRestE = Array(#1:00:00 PM#, #3:10:00 PM#, #5:30:00 PM#) '残業時間 vntOver = #8:00:00 PM# With rngList '行数の取得 lngRows = .Offset(Rows.Count - .Row, clngMan).End(xlUp).Row - .Row + 1 If lngRows <= 0 And IsEmpty(.Value) Then strProm = "データが有りません" GoTo Wayout End If '列データを配列に取得 vntData = .Offset(, clngMan).Resize(lngRows + 1).Value End With '時刻をマス位置に変換 For i = 0 To UBound(vntRestE) vntRestS(i) = TimeConv(vntRestS(i), cdblStart) vntRestE(i) = TimeConv(vntRestE(i), cdblStart) - 1 Next i vntOver = TimeConv(vntOver, cdblStart) '指標を作成 ReDim lngIndex(1 To TimeConv(cdblEnd, cdblStart)) For i = 1 To UBound(lngIndex, 1) '時間内なら If i < vntOver Then '休憩時間を確認 For j = 0 To UBound(vntRestE) If vntRestS(j) <= i And i <= vntRestE(j) Then Exit For End If Next j '休憩時間内なら If j <= UBound(vntRestE) Then '指標を-1に lngIndex(i) = -1 Else '指標を時間内のRGBに lngIndex(i) = clngColor1 End If Else '指標を時間外のRGBに lngIndex(i) = clngColor2 End If Next i '画面更新を停止 Application.ScreenUpdating = False '「工数」列に就いて繰り返し j = 0 For i = 1 To lngRows j = j + 1 'グループ先頭から3行目以降なら If j > 2 Then If IsEmpty(vntData(i, 1)) Then 'グループ先頭に j = 0 Else '10分単位に変換（1分の部分は切り上げ） vntData(i, 1) = -Int(-vntData(i, 1) / 10) '行程表の色付けるセル先頭に就いて With rngList.Cells(i, clngMan + 1 + 1) '1行分色をクリア .Resize(, UBound(lngIndex)).Interior.Pattern = xlNone '色を付けるセル数をクリア lngCount = 0 '色を付けるセル数が工数を上回れば終了 Do Until lngCount > vntData(i, 1) '色を付けるセル先頭が常に休憩時間の後ろに成る様に Do Until lngIndex(lngPos) > -1 lngPos = lngPos + 1 Loop '工数がオーバーした場合 If lngPos + lngCount > UBound(lngIndex) Then Exit Do End If '休憩時間若しくは時間外に成った場合 If lngIndex(lngPos) <> lngIndex(lngPos + lngCount) Then '色付セル先頭から色付セル数分、色付する With .Offset(, lngPos - 1).Resize(, lngCount) .Interior.Pattern = xlSolid .Interior.Color = lngIndex(lngPos) End With '色付セル先頭位置を更新 lngPos = lngPos + lngCount '工数から色付数を減算 vntData(i, 1) = vntData(i, 1) - lngCount - 1 '色付数を初期化 lngCount = 0 Else '色付数を加算 lngCount = lngCount + 1 End If Loop '色付数が在るなら If lngCount > 0 Then '色付セル先頭から色付セル数分、色付する With .Offset(, lngPos - 1).Resize(, lngCount) .Interior.Pattern = xlSolid .Interior.Color = lngIndex(lngPos) End With End If '色付セル先頭位置を更新 lngPos = lngPos + lngCount End With End If Else '「工数」の行に来たら色付セル先頭位置を初期化 If j = 2 Then lngPos = 1 End If End If Next i strProm = "処理が完了しました" Wayout: '画面更新を再開 Application.ScreenUpdating = True Set rngList = Nothing MsgBox strProm, vbInformation End Sub Private Function TimeConv(vntTime As Variant, dblStart As Double) As Long Dim lngTime As Long lngTime = (Hour(vntTime) * 60 + Minute(vntTime)) _ - (Hour(dblStart) * 60 + Minute(dblStart)) TimeConv = lngTime ¥ 10 + 1 End Function (Bun) ---- >1グループ内で並行作業は行いません。 >トマトが終わったらキャベツ、キャベツが終わったらキュウリと、1製品ごとに流していきます。 確認したのは、アップされた質問文の中で、同じグループ内でキャベツとキュウリ両方が15:20のセルを使っているけど? ということだったんんだけど、質問文の書き間違いだったのかな? きっと、実際のシートの状況や、特に、前もって休憩時間に色が塗られている、その場所等、誤解が多々あるかもしれないけど。 そうそう、コードを書いてアップされたテストデータでテストして、何度もエラーになったよ。 なので、セットする前に、対象時間帯（たぶんCO列が最後かな?）をこえたら、メッセージを出して処理を終了させている。 Option Explicit Dim breakR1 As Range Dim breakR2 As Range Dim breakR3 As Range Sub Sample() Dim i As Long Dim svCidx As Long Dim stC As Range Dim num As Long Dim breakR As Range Dim skip As Boolean Dim myBar As Range Application.ScreenUpdating = False With Sheets("Sheet1") svCidx = .Range("AB1").Interior.ColorIndex '休憩時間の塗りつぶしの色 Set breakR1 = .Columns("AB:AG") '休憩時間帯 お昼 Set breakR2 = .Columns("AT") '休憩時間帯 三時のおやつ Set breakR3 = .Columns("BF:BH") '休憩時間帯 夕方 Set breakR = Union(breakR1, breakR2, breakR3) '全休憩時間帯 i = 3 'データ開始行 Do While Len(.Cells(i, "A").Value) > 0 Set stC = .Cells(i, "D") Do While Len(.Cells(i, "A").Value) > 0 num = WorksheetFunction.RoundUp(.Cells(i, "C").Value / 10, 0) If num > 0 Then Set myBar = getBar(stC, num) If myBar Is Nothing Then skip = True Exit Do End If .Range(.Cells(i, "D"), .Cells(i, "CO")).Interior.ColorIndex = xlNone myBar.Interior.ColorIndex = 46 'オレンジ Intersect(.Rows(i), breakR).Interior.ColorIndex = svCidx Set stC = stC.Offset(1, myBar.Count) End If i = i + 1 Loop If skip Then Application.ScreenUpdating = True MsgBox i & "行目の " & .Cells(i, "A").Value & " の処理には列数が不足しています" _ & vbLf & "処理を終了します" Exit Do End If i = i + 3 Set stC = stC.Offset(3, num) Loop '20時以降のオレンジを赤に変換 Application.FindFormat.Interior.ColorIndex = 46 'オレンジ Application.ReplaceFormat.Interior.ColorIndex = 3 '赤 .Columns("BX:CO").Replace What:="", Replacement:="", LookAt:=xlPart, _ SearchFormat:=True, ReplaceFormat:=True End With Set stC = Nothing Set breakR = Nothing Set breakR1 = Nothing Set breakR2 = Nothing Set breakR3 = Nothing Set myBar = Nothing Application.ScreenUpdating = True MsgBox "処理が終わりました" End Sub Private Function getBar(ByVal stC As Range, ByVal num As Long) As Range Dim x As Long Dim r As Variant Dim w As Range x = stC.Column If x + num - 1 > Columns("CO").Column Then Exit Function For Each r In Array(breakR1, breakR2, breakR3) Set w = Intersect(stC.Resize(, num), r) If Not r Is Nothing Then num = num + r.Count If x + num - 1 > Columns("CO").Column Then Exit Function Next Set w = Nothing Set getBar = stC.Resize(, num) End Function (ぶらっと) ---- >オーバーした場合、工程管理者が生産工数を減らし時間内に収まるように工数を調整致します。 アップしたコードは、1行でも列オーバしていると、そこで処理そのものを打ち切っているけど、 そのグループを打ち切り、続いて、次のグループの処理をしたほうがいいんだね。 後ほど、リバイス版をアップ予定。 (ぶらっと) ---- ごめん、検証不足で思った通りに動いていませんでした 以下の★印に修正して下さい 此れで、私の思った動きですので、FAさんの考えていた物と比較して下さい? '指標を作成 ' ReDim lngIndex(1 To TimeConv(cdblEnd, cdblStart)) ReDim lngIndex(1 To TimeConv(cdblEnd, cdblStart) + 1) '★変更 For i = 1 To UBound(lngIndex, 1) '工数から色付数を減算 ' vntData(i, 1) = vntData(i, 1) - lngCount - 1 vntData(i, 1) = vntData(i, 1) - lngCount '★変更 '色付数を初期化 Loop '色付数が在るなら ' If lngCount > 0 Then If lngCount - 1 > 0 Then '★変更 '色付セル先頭から色付セル数分、色付する ' With .Offset(, lngPos - 1).Resize(, lngCount) With .Offset(, lngPos - 1).Resize(, lngCount - 1) '★変更 .Interior.Pattern = xlSolid .Interior.Color = lngIndex(lngPos) End With End If '色付セル先頭位置を更新 ' lngPos = lngPos + lngCount'★変更 lngPos = lngPos + lngCount - 1 End With End If Else '「工数」の行に来たら色付セル先頭位置を初期化 (Bun) ---- リバイス版 getBar は変更なし。Sampleのみ以下に。 Sub Sample() Dim i As Long Dim svCidx As Long Dim stC As Range Dim num As Long Dim breakR As Range Dim skip As Boolean Dim myBar As Range Application.ScreenUpdating = False With Sheets("Sheet1") svCidx = .Range("AB1").Interior.ColorIndex '休憩時間の塗りつぶしの色 Set breakR1 = .Columns("AB:AG") '休憩時間帯 お昼 Set breakR2 = .Columns("AT") '休憩時間帯 三時のおやつ Set breakR3 = .Columns("BF:BH") '休憩時間帯 夕方 Set breakR = Union(breakR1, breakR2, breakR3) '全休憩時間帯 i = 3 'データ開始行 Do While Len(.Cells(i, "A").Value) > 0 Set stC = .Cells(i, "D") Do While Len(.Cells(i, "A").Value) > 0 num = WorksheetFunction.RoundUp(.Cells(i, "C").Value / 10, 0) If num > 0 Then Set myBar = getBar(stC, num) If myBar Is Nothing Then skip = True Exit Do End If .Range(.Cells(i, "D"), .Cells(i, "CO")).Interior.ColorIndex = xlNone myBar.Interior.ColorIndex = 46 'オレンジ Intersect(.Rows(i), breakR).Interior.ColorIndex = svCidx Set stC = stC.Offset(1, myBar.Count) End If i = i + 1 Loop If skip Then Application.ScreenUpdating = True MsgBox i & "行目の " & .Cells(i, "A").Value & " の処理には列数が不足しています" _ & vbLf & "このグループの処理を終了します" Do i = i + 1 If Len(.Cells(i, "A").Value) = 0 Then i = i + 3 Exit Do End If Loop Else i = i + 3 Set stC = stC.Offset(3, num) End If Loop '20時以降のオレンジを赤に変換 Application.FindFormat.Interior.ColorIndex = 46 'オレンジ Application.ReplaceFormat.Interior.ColorIndex = 3 '赤 .Columns("BX:CO").Replace What:="", Replacement:="", LookAt:=xlPart, _ SearchFormat:=True, ReplaceFormat:=True End With Set stC = Nothing Set breakR = Nothing Set breakR1 = Nothing Set breakR2 = Nothing Set breakR3 = Nothing Set myBar = Nothing Application.ScreenUpdating = True MsgBox "処理が終わりました" End Sub (ぶらっと) ---- Bun様 教えて頂いたコードを早速試してみました。叩き台どころかほぼ完璧でした! このコードを解析して追加で修正してみます。 修正時にまた分からないことが出て来るかも知れませんがご教授お願います。 ありがとうございました! PS: 以前教えて頂いたコードは、素人ながらにも手を加えて運用しています。 VBAは考えてる通り動くと楽しいですね。 と言っても私ができることは、まだ本に書いてある初歩的なことしかできませんが(笑) 何度も挫折しそうになりましたが、Bun様達先生方のお陰で諦めず泣きながらVBAを楽しんでいます。 ぶらっと様 私の至らない説明でリバイス版までご検討頂きありがとうございます。 リバイス版でご確認させて頂いたところ、理想に近い処理ができました! 修正するにあたり分からない事が出て来ると思いますが、その節は再度ご指導願います。 しかしお二人とも凄いですね。私はこの処理に3週間ほど悩み続け匙を投げたのにお二人は1時間程度でしてしまうとは・・・ 本当にお二人のコードは修正するところがほとんどありません(笑) お二人にご教授頂いたコードは一行づつ確認して自分の物にしていきたいと思います。 またご教授お願い致します。 本当にありがとうございました! (FA)... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201203/20120314194032.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97041 documents and 608053 words.
訪問者：