Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge = 1 And Not Intersect(Range("A:A"), Target) Is Nothing Then
On Error GoTo Escape
Dim c As Range, i As Long, a
Target.Offset(, 1).Resize(, 7).Interior.Color = xlNone
Select Case UCase(Target.Value2)
Case Is = "BED"
a = Array(2, 3, 5)
Case Is = "CHAIR"
a = Array(1, 2, 3)
Case Is = "TABLE"
a = Array(4, 5, 7)
Case Else
GoTo Continue
End Select
Set c = Target.Offset(, 1).Resize(, 7)
With c
.Interior.Color = xlNone
For i = 0 To UBound(a)
.Cells(1, a(i)).Interior.Color = RGB(217, 217, 217)
Next i
End With
End If
Continue:
Application.EnableEvents = True
Exit Sub
Escape:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Continue
End Sub