複数セル参照で塗りつぶしを変更する

質問

WIN:XP Off:2003
お願いします。　添付した図は入出金表です。
列Hに数値が入力されると列Eのセルが青く塗りつぶされます。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rng As Range
Dim aCell As Range

Set Rng = Intersect(Target, Range("H:H"))

If Rng Is Nothing Then Exit Sub
For Each aCell In Rng
If aCell.Value > 0 Then
aCell.Offset(0, -3).Interior.ColorIndex = 17
Else
aCell.Offset(0, -3).Interior.ColorIndex = xlNone
End If
Next aCell

Set Rng = Nothing

End Sub

ここまでは出来たのですが、列Iに入力された時に列Eが赤に塗りつぶされるにはどうしたらいいでしょうか？
同じ行のHとIに同時に数値が入る事はありません。

どうかお願い致します。

回答No.3

mu2011 · ベストアンサー

コードが冗長なので整理してみました。（Ｈ，Ｉ入力の妥当性は人任せです）
因みに色付けなら条件付き書式で設定した方が簡単ではないでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range, cl As Integer
If Intersect(Target, Range("H:I")) Is Nothing Then Exit Sub
For Each aCell In Target
Select Case aCell.Column
Case Is = 8: cl = 17
Case Is = 9: cl = 3
End Select
If aCell.Value = 0 Then cl = xlNone
Cells(aCell.Row, "E").Interior.ColorIndex = cl
Next aCell
End Sub

お礼

mu2011さん。
初めに条件付き書式を試したのですが、同じ条件を複数の行に設定することが出来なかった次第です。
どちらも勉強不足です。　ありがとうございました。

回答No.2

m-take0220

＞ If Rng Is Nothing Then Exit Sub

このコードが何を意味するかはご存じですか?

Rngに何も設定されていない場合は、関数を抜ける(=処理を終了する)ということです。
先にH列の処理をしているので、変更されたセル範囲(Target)にH列のセルが含まれていないと、前述のコードで処理が終了してしまいます。

判断の仕方を変えて、

If Not Rng Is Nothing Then
For Each aCell In Rng
If aCell.Value > 0 Then
aCell.Offset(0, -3).Interior.ColorIndex = 17
Else
aCell.Offset(0, -3).Interior.ColorIndex = xlNone
End If
Next aCell
End If

とすると、For～Nextの処理はRngに何かのセルがある場合だけ実行されるようになります。

お礼

m-take0220さん　希望通りの表示が出来ました。
おっしゃるとおりですね。　気付かないという事も勉強不足です。
ありがとうございました。助かりました。

回答No.1

bin-chan

Set Rng = Nothingの前の行に列Ｈから列Ｅに対する処理一通りをコピぺして、
列Ｊから列Ｅに対する処理を追加してください。

' ここの H を J にする。
Set Rng = Intersect(Target, Range("I:I"))

（中略）

' -3が対象セル（列H）の３列左（列E）を指している
' 列Jから見た列Eは５列左だからoffsetは-5
' ColorIndexは「マクロの記録」を行って調べてね
aCell.Offset(0, -5).Interior.ColorIndex = 3

お礼

bin-chanさん、私の勉強不足でした。
有難うございました。

補足

bin-chanさん、有難うございます。
以下でいいのでしょうか？　変色は出来なかったのですが…

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rng As Range
Dim aCell As Range

Set Rng = Intersect(Target, Range("H:H"))

If Rng Is Nothing Then Exit Sub
For Each aCell In Rng
If aCell.Value > 0 Then
aCell.Offset(0, -3).Interior.ColorIndex = 17
Else
aCell.Offset(0, -3).Interior.ColorIndex = xlNone
End If
Next aCell

Set Rng = Intersect(Target, Range("I:I"))

If Rng Is Nothing Then Exit Sub
For Each aCell In Rng
If aCell.Value > 0 Then
aCell.Offset(0, -4).Interior.ColorIndex = 22
Else
aCell.Offset(0, -4).Interior.ColorIndex = xlNone
End If
Next aCell

Set Rng = Nothing

End Sub