|
埃 さん、STi さん、こんばんは。
再送です。
シートのChangeイベントを使いました。
当該シートのシートモジュールに
'===============================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newtarget As Range
Dim crng As Range
Dim 東西南北 As String
Dim 色()
東西南北 = "東西南北"
色() = Array(xlNone, 3, 5, 10, 13)
' 色ナシ、赤、青、緑、紫
Application.EnableEvents = False
Set newtarget = Application.Intersect(Target, Range("b2:b65536"))
' ↑セルB2以降を対象
If Not newtarget Is Nothing Then
For Each crng In newtarget
With crng.Offset(0, 3).Interior
If crng.Value <> "" Then '未入力のとき処理は分岐
.ColorIndex = 色(InStr(東西南北, crng.Value))
' 厳密にはMatch関数の方がよいかも?
Else
.ColorIndex = xlNone
End If
If .ColorIndex > 0 Then .Pattern = xlSolid
End With
Next
End If
Application.EnableEvents = True
End Sub
確認してみて下さい。
|
|