[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『セルの塗りつぶし』（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
(ぶらっと)
>オーバーした場合、工程管理者が生産工数を減らし時間内に収まるように工数を調整致します。
アップしたコードは、１行でも列オーバしていると、そこで処理そのものを打ち切っているけど、 そのグループを打ち切り、続いて、次のグループの処理をしたほうがいいんだね。
後ほど、リバイス版をアップ予定。
(ぶらっと)
ごめん、検証不足で思った通りに動いていませんでした 以下の★印に修正して下さい 此れで、私の思った動きですので、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)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.