VBAで日付分塗りつぶす

質問

添付画像のようなシートで
例えばI9セルに4と入力すると
J9セルからY9セルまで（つまり4日間）を塗りつぶすような
コードがしりたいです。
入力する数値はランダムですのでその数値に合わせて
日にち分塗りつぶしを行いたいです。

宜しくお願いします。

回答No.3

HohoPapa · ベストアンサー

>数値を消した場合、塗りつぶされていたところも
>塗りつぶしなしの状態に戻す

0、空欄、数値以外が埋まった時に消すようにしてみました。
また、細かなところを直しました。

Private Sub Worksheet_Change(ByVal Target As Range)

　Dim MyRange As Range
　Const ColsUnit = 4　　　 '1日当たりの列数
　Const ClearDays = 10　　 '空欄の時に該当行の背景色を消す日数
　Const MyColor = 5287936　'背景色

　With ThisWorkbook.ActiveSheet
　　If ((Target.Column Mod ColsUnit = 1) And _
　　　　(Target.Column > 5)) Then
　　　If ((Target.Value > 0) And IsNumeric(Target.Value)) Then
　　　　Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
　　　　　　　　　　　　　.Cells(Target.Row, Target.Column + Target.Value * ColsUnit))
　　　　MyRange.Interior.Color = MyColor
　　　Else
　　　　Set MyRange = _
　　　　　　Range(.Cells(Target.Row, Target.Column + 1), _
　　　　　　　　　.Cells(Target.Row, Target.Column + (ClearDays * ColsUnit)))
　　　　MyRange.Interior.Pattern = xlNone
　　　End If
　　End If
　End With

End Sub

お礼

素晴らしいコードを本当ありがとうございました。
目的の事が行えました。
ありがとうございます。

回答No.2

HohoPapa

先ほどのコードでは、A列、E列に値が埋まっても反応してしまい、
更に、0が埋まった時にも反応してしまうので
再掲示します。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim MyRange As Range
　Const MyColor = 5287936

　With ThisWorkbook.ActiveSheet
　　If ((Target.Column Mod 4 = 1) And _
　　　　(Target.Column > 5) And _
　　　　(Target.Value > 0)) Then

'　　　Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
'　　　　　　　　　　　　　.Cells(Target.Row, Target.Column + 4))
'　　　MyRange.Interior.Pattern = xlNone

　　　If Target.Value <> "" Then
　　　　Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
　　　　　　　　　　　　　.Cells(Target.Row, Target.Column + Target.Value * 4))
　　　　MyRange.Interior.Color = MyColor
　　　End If
　　End If

　End With

End Sub

補足

ありがとうございます。
望み通りのことができました。
これはもしできればでよろしいのですが
数値を消した場合、塗りつぶされていたところも
塗りつぶしなしの状態に戻すことはできないでしょうか？

回答No.1

HohoPapa

例えば、
I列に３が埋まったら、
右隣りから右方向に　4列/日*3=12個のセルの背景色を何らかの色に染めるんですね。
その後、Q列に2が埋まったらどのような動きにすればいいでしょうか？。

更に、
Q列に2が埋まったまま
I列の3が1に書き換わったら
どのような動きをすればいいでしょうか？

更に例えば
その後、Q列に埋まっている2を空欄に置き換えたら
どのような動きにすればいいでしょうか？

そういったことを考えなくていいのであれば
次のようなコードでいけるんじゃないかと思います。

なお、I列など、投入列に数値以外が埋まることを想定していません。
数値以外が入った時にどうすればいいかを説明してくれれば
対応できると思います。

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim MyRange As Range
　Const MyColor = 5287936

　With ThisWorkbook.ActiveSheet
　　If Target.Column Mod 4 = 1 Then

'　　　Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
'　　　　　　　　　　　　　.Cells(Target.Row, Target.Column + 4))
'　　　MyRange.Interior.Pattern = xlNone

　　　If Target.Value <> "" Then
　　　　Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
　　　　　　　　　　　　　.Cells(Target.Row, Target.Column + Target.Value * 4))
　　　　MyRange.Interior.Color = MyColor
　　　End If
　　End If

　End With

End Sub