| 
    
     |  | 埃 さん、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
 
 確認してみて下さい。
 
 |  |