View Single Post
 
Old 08-28-2012, 07:30 AM
Catalin.B Catalin.B is offline Windows Vista Office 2010 32bit
Expert
 
Join Date: May 2011
Location: Iaşi, Romānia
Posts: 386
Catalin.B is on a distinguished road
Default

I have to admit that i was wrong when i said that a change event does not respond to a Data Validation change ; the code will work every time you make a selection in column D or you clear the cell; the code you needed is presented below and must be pasted in Sheet 1 module. Sorry, my mistake !

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rng As Range
        
        Set rng = Target.Parent.Range("D1:D350")
             
            If Target.Count > 1 Then Exit Sub
            
            If Intersect(Target, rng) Is Nothing Then Exit Sub
            
            With Target

    SearchArr = Array("BLACK", "BLUE", "CADIAC ALERT", "GREEN", "GREY", "ICE ALERT", "ORANGE" _
       , "PEDS CODE BLUE", "PINK", "PURPLE", "RAPID RESPONSE", "RED", "STEMI ALERT", "STROKE ALERT" _
       , "WHITE", "YELLOW")
    FontColorArr = Array("2", "2", "2", "1", "1", "1", "1", "1" _
       , "2", "2", "1", "2", "2", "1", "1", "1")
    InteriorColorArr = Array("1", "5", "30", "4", "16", "37", "46", "8" _
       , "7", "13", "20", "3", "53", "22", "2", "6")
           For i = LBound(SearchArr) To UBound(SearchArr)
If Len(Target) = 0 Then Target.Interior.ColorIndex = 2: Target.Font.ColorIndex = 1
        If InStr(1, Target.Text, SearchArr(i), vbTextCompare) > 0 Then
        .Interior.ColorIndex = InteriorColorArr(i)
        .Font.ColorIndex = FontColorArr(i)
        End If
           Next i

    End With
End Sub
Reply With Quote