Change Cell Colors with each change of a drop down list value

[Wolfster63]

I am trying to modify a status board for our hospital operating room that will enable whoever is updating the board to change the color of cells according to a value selected from a drop down box.

Unfortunately, I can't use conditional formatting hence the VBA route. I have be experimenting with some code as follows:

Sub ColorMeElmo()
Dim i As Long, r1 As Range, r2 As Range
For i = 2 To 15
Set r1 = Range("D" & i)
Set r2 = Range("A" & i & ":C" & i)
If r1.Value = "Turn Over" Then r2.Interior.Color = RGB(255, 0, 51)
If r1.Value = "Closing" Then r2.Interior.Color = RGB(255, 153, 0)
If r1.Value = "In OR" Then r2.Interior.Color = RGB(255, 255, 0)
If r1.Value = "Ready" Then r2.Interior.Color = RGB(255, 255, 255)
If r1.Value = "Done" Then r2.Interior.Color = RGB(255, 255, 255)
If r1.Value = "Done" Then r2.Font.Color = RGB(255, 255, 255)
Next i
End Sub


I need the code to execute each time a different value is selected from the drop down list. Right now, it only executes when the sheet is loaded.

I am not that proficient with VBA. I am hoping this could be a really simple fix.

Thanks in advance,

Will

 

[Ron Coderre]

"Can't" use conditional formatting?
- Trouble getting it to work?
- Don't know how to use it?
- Forbidden from using it?
- Something else?

 

[Wolfster63]

Our folks constantly cut and paste, to move things around on the board. The Conditional Formatting ranges goes right along with the Cut and Paste, so out board looks like a patchwork quilt quickly. I intend to have the drop down off to the side and have the ranges change colors with only the code in the button making the background change.

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Make a selection in the drop downs in D2:D15.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D2:D15")) Is Nothing Then Exit Sub
    Select Case Target.Value
        Case "Turn Over"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 0, 51)
        Case "Closing"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 153, 0)
        Case "In OR"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 255, 0)
        Case "Ready", "Done"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 255, 255)
    End Select
End Sub

 

[Wolfster63]

Awesome! Works great. But I need the font to go white when the user selects "Done" so the text dissappears off the board visually, but the user can still cut and paste the values if needed later.

 

[mumps]

Try:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D2:D15")) Is Nothing Then Exit Sub
    Select Case Target.Value
        Case "Turn Over"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 0, 51)
        Case "Closing"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 153, 0)
        Case "In OR"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 255, 0)
        Case "Ready"
            Range("A" & Target.Row & ":C" & Target.Row).Interior.Color = RGB(255, 255, 255)
        Case "Done"
            With Range("A" & Target.Row & ":C" & Target.Row)
                .Interior.Color = RGB(255, 255, 255)
                .Font.Color = vbWhite
            End With
    End Select
End Sub

 

[Wolfster63]

Works great! Thanks so much!

 

[Wolfster63]

One more question.

Is there a way to add a second range to this?

This would allow me to add another column so say D2:D15 and L2:L15? with the L2:L15 ranges affecting Corresponding I, J, and K Rows?

I'm hoping it's just something simple.

If not, no harm no foul,

Thanks again,

Will

 

[My Aswer Is This]

Try this:
I modified Mumps script

Private Sub Worksheet_Change(ByVal Target As Range)
    'Modified 5/2/18 6:15 PM EDT
    If Intersect(Target, Range("D2:D15,L2:L15")) Is Nothing Then Exit Sub
    If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
    Dim r As Long
    Dim c As Long
    r = Target.Row
    c = Target.Column
    Select Case Target.Value
        Case "Turn Over"
            Cells(r, c).Offset(, -3).Resize(, 3).Interior.Color = RGB(255, 0, 51)
        Case "Closing"
            Cells(r, c).Offset(, -3).Resize(, 3).Interior.Color = RGB(255, 153, 0)
        Case "In OR"
            Cells(r, c).Offset(, -3).Resize(, 3).Interior.Color = RGB(255, 255, 0)
        Case "Ready"
            Cells(r, c).Offset(, -3).Resize(, 3).Interior.Color = RGB(255, 255, 255)
        Case "Done"
            Cells(r, c).Offset(, -3).Resize(, 3).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, -3).Resize(, 3).Font.Color = vbWhite
        
    End Select
End Sub

 

[Wolfster63]

Thanks for all the help guys.

I was adapt the script to our current board, which is some 63 rows deep (with 2 columns of rooms) and has merged cells. Now our folks can simply click on the drop down list and change the status of the room.

The status board is displayed in various areas of our surgical floor and is used to communicate to staff in PreOp, OR, and Recovery.

We couldn't use conditional formatting as the board supervisors often cut and paste similar information between rooms as cases are suffled and reordered often throughout the day. When you cut and paste a conditionally formatted range, it takes the conditional formatting with it. The board will look like a quilt in a few hours.

Anyhow, this vba solution will allow the folks to cut and paste information to their heart's content.

Thanks again, especially to Mumps and My Answer is This

Here is the final version of the script (please forgive my not being able to format the lines correctly):

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified 5/2/18 6:15 PM EDT
If Intersect(Target, Range("A3:A62,L3:L63")) Is Nothing Then Exit Sub
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
Dim r As Long
Dim c As Long
r = Target.Row
c = Target.Column
Select Case Target.Value
Case "Turn Over"
Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 0, 51)
Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 0, 51)
Case "Closing"
Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 153, 0)
Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 153, 0)
Case "In OR"
Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 0)
Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 0)
Case "Ready"
Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255)
Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255)
Case "Done"
Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, 1).Resize(, 9).Font.Color = vbWhite
Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Color = vbWhite
End Select
End Sub​