Change cell color when selection is made from a drop down list

Catalin.B · #1 08-22-2012, 10:19 AM

Another approach to your problem is to work with arrays instead of select case (Note: All 3 arrays must have the same number of elements).
The problem is that selecting a value from a drop down list (or the result of a formula) does not trigger an event that can be intercepted by Worksheet change event, so the code below will not work until you double click the cell and exit with enter (editing a cell is a Workbook_Change event) , AFTER you select from list....

You might reconsider your work steps, and run a slightly modified code from a button after selecting all the entries, or using the Before_Close event to run the code. Place this code under Sheet module, works for column 4 (D), under row 400 (change this in code as needed).

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim SearchArr, FontColorArr, InteriorColorArr As Variant, i As Integer

 If Target.Column = 4 And Target.Row < 400 Then
    With ActiveCell.Offset(-1, 0)

    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 InStr(1, ActiveCell.Offset(-1, 0).Text, SearchArr(i), vbTextCompare) > 0 Then
        ActiveCell.Offset(-1, 0).Interior.ColorIndex = InteriorColorArr(i)
        ActiveCell.Offset(-1, 0).Font.ColorIndex = FontColorArr(i)
        End If
           Next i

    End With
 End If
End Sub

Catalin.B · #2 08-23-2012, 11:24 PM

Here is the code, same that can be found in the workbook attached, which works with the event Workbook_BeforeClose.
The code will execute and change fonts and interior color on column D when you hit the close button on the workbook.
You have to complete the arrays, i noticed that you have in the workbook more values than in your first message. Remember that the arrays must have the same number of elements.
The code works on active sheet, so , if you want to run the code on another sheet, you just have to activate that sheet before closing the workbook.

Code:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim SearchArr, FontColorArr, InteriorColorArr As Variant, i, Cell As Integer
    SearchArr = Array("BLACK", "BLUE", "CADIAC ALERT", "GREEN", "GRAY", "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")
     Application.ScreenUpdating=False
For Cell = 3 To 350
           For i = LBound(SearchArr) To UBound(SearchArr)
              If InStr(1, ActiveSheet.Cells(Cell, "D").Text, SearchArr(i), vbTextCompare) > 0 Then
                ActiveSheet.Cells(Cell, "D").Interior.ColorIndex = InteriorColorArr(i)
                ActiveSheet.Cells(Cell, "D").Font.ColorIndex = FontColorArr(i)
              End If
           Next i
   Next Cell
    Application.ScreenUpdating=True
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro ? - Checkbox in Word + drop down selection help	dice1976	Word	4	07-24-2012 11:18 AM
Change cell color everytime a value is selected in dropdown list	angelica_gloria	Excel	4	01-27-2012 06:47 PM
Made a mistake with a macro change	lance_kidd	Word	0	02-09-2011 06:36 PM
Ho to perform multi selection in drop down lists?	nashville	Word	0	09-29-2010 07:10 AM
How can I fill cell color starting from Cell D5 using Conditional formatting instead	Learner7	Excel	0	07-08-2010 05:50 AM