VBA 塗りつぶしルール

質問

現在下記のコードで添付画像の表の塗りつぶしを行っています。
例えばI9セルに数字を入力するとその横のJ9セルからY9セルまで（４日間）を塗りつぶすというコードです。

今回行いたいのは
上記のようにI9セルに数値を入れた際に、U9セルまではいいのですが
V9からY9、つまり休日は飛ばして、残り一日分をAD9から始めたいといったことが行いたいです。

日付と曜日を塗りつぶしている色はColorIndex = 38です。
これを条件などにすればできますでしょうか？

ちなみに画像は土日のみが休日になっていますが
もちろん祝日の場合もColorIndex = 38で日付と曜日を
塗りつぶしますので、月火をのところで塗りつぶして水曜日は空けて木金で塗りつぶすといった場合もあります。

このようなことができるのかわかりませんが
もし分かれば教えてください。
よろしくお願いします。

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 + 16))
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

mt2015 · ベストアンサー

> 関係あるかわかりませんが、2行目の日付が入っているセルはF列からI列まで、J列からM列まで・・・、といった感じで4列ずつで結合されています。
> これが原因なのでしょうか？

これです……。
結合セルは右上のセルだけが塗りつぶされている扱いになります。

必ず4列づつ結合されていると言う前提でコードを修正しました。

nCol = Target.Column + 1
nCount = 0
Do While nCount < 16
　　If Cells(2, nCol).Interior.ColorIndex <> 38 Then
　　　　If nCount = 0 Then
　　　　　　Set MyRange = Range(Cells(Target.Row, nCol), Cells(Target.Row, nCol + 3))
　　　　Else
　　　　　　Set MyRange = Union(MyRange, Range(Cells(Target.Row, nCol), Cells(Target.Row, nCol + 3)))
　　　　End If
　　　　nCount = nCount + 4
　　End If
　　nCol = nCol + 4
Loop

お礼

ありがとうございます。
頂いたコードで望み通りの操作が行えました。
本当にありがとうございました。

回答No.3

mt2015

訂正
誤：結合セルは右上のセルだけが塗りつぶされている扱いになります
正：結合セルは左上のセルだけが塗りつぶされている扱いになります

回答No.1

mt2015

図が細かすぎて良く見えないのですが、2行目がColoeIndex=38なら色を塗らないって事で良いんでしょうか。
こんな感じでどうでしょう。元のコードの一部を以下の様に書き換えてください。

Set MyRange = Range(.Cells(Target.Row, Target.Column + 1), _
.Cells(Target.Row, Target.Column + 16))
↓
nCol = Target.Column + 1
nCount = 0
'2行目がColorIndex=38では無いセルを16個 MyRangeにセット
Do While nCount < 16
　　If Cells(2, nCol).Interior.ColorIndex <> 38 Then
　　　　If nCount = 0 Then
　　　　　　Set MyRange = Cells(Target.Row, nCol)
　　　　Else
　　　　　　Set MyRange = Union(MyRange, Cells(Target.Row, nCol))
　　　　End If
　　　　nCount = nCount + 1
　　End If
　　nCol = nCol + 1
Loop

補足

図が見ずらい件、申し訳ございません。
頂いたコードを試してみました。
実行すると土曜のR9セルと日曜のV9セルは塗りつぶされなかったのですが
土曜日のS9からU9と日曜のW9からY9セルが塗りつぶされてしまいました。
関係あるかわかりませんが、2行目の日付が入っているセルはF列からI列まで、J列からM列まで・・・、といった感じで4列ずつで結合されています。
これが原因なのでしょうか？