Upgrading my status board...

W

Wolfster63

New Member
Joined
May 2, 2018
Messages
24
Back in early May, with the help of Mumps and My Answser is this, I was able to create a status board used by our operating room. Because Conditional Formating was not an option, we used VBA that changed the colors of a group of cells based on a drop down box value.



The following code works great:

Code: 
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
        Case "Cancelled"
            Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, 1).Resize(, 9).Font.Color = vbRed: Cells(r, c).Offset(, 1).Resize(, 9).Font.Strikethrough = True
            Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Color = vbRed: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Strikethrough = True
        Case "Reset"
            Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, 1).Resize(, 9).Font.Color = vbBlack: Cells(r, c).Offset(, 1).Resize(, 9).Font.Strikethrough = False: Cells(r, c).Offset(, 1).Resize(, 9).Font.FontStyle = "Bold"
            Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Color = vbBlack: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Strikethrough = False: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.FontStyle = "Bold"
    End Select
End Sub


What would be great would be if the cells would flash for about 20 seconds before ending up with the final color. This could alert folks as to a patient getting ready to come out of the OR.

I've tried a few solutions unsucessfully.

Any ideas?

Will
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Try this and adapt to your requirements

Code: 
Sub TestIt()
    Dim r As Long, c As Long
    r = 5: c = 4
    Call flash(Cells(r, c))
End Sub

Private Sub flash(cell As Range)
    Dim c, f, a
    c = cell.Interior.Color
    f = vbBlue
        For a = 1 To 20
            With cell.Interior
                If .Color = f Then .Color = c Else .Color = f
            End With
            Application.Wait (Now + TimeValue("00:00:01"))
        Next a
    cell.Interior.Color = c
End Sub
 
Upvote 0
Well, partial success. I am hoping for a really simple answer here.

I can get the rows to flash the appropriate colors, but I would like to have the second range flash as well. Have tried "And" to combine the ranges, but keep getting a mismatch error.

Code: 
...
        Case "Closing"
            Call flash_closing(Cells(r, c).Offset(, 1).Resize(, 9) And Cells(r + 1, c).Offset(, 1).Resize(, 9))
            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)
...

Is there anyway to combine these two ranges, so that they flash together?

Code: 
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)

Here's the entire code:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    'Modified 6/26/18  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"
            Call flash_turn(Cells(r, c).Offset(, 1).Resize(, 9))
            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"
            Call flash_closing(Cells(r, c).Offset(, 1).Resize(, 9))
            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
        Case "Cancelled"
            Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, 1).Resize(, 9).Font.Color = vbRed: Cells(r, c).Offset(, 1).Resize(, 9).Font.Strikethrough = True
            Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Color = vbRed: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Strikethrough = True
        Case "Reset"
            Cells(r, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r, c).Offset(, 1).Resize(, 9).Font.Color = vbBlack: Cells(r, c).Offset(, 1).Resize(, 9).Font.Strikethrough = False: Cells(r, c).Offset(, 1).Resize(, 9).Font.FontStyle = "Bold"
            Cells(r + 1, c).Offset(, 1).Resize(, 9).Interior.Color = RGB(255, 255, 255): Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Color = vbBlack: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.Strikethrough = False: Cells(r + 1, c).Offset(, 1).Resize(, 9).Font.FontStyle = "Bold"
    End Select
End Sub
Private Sub flash_closing(cell As Range)
    Dim c, f, a
    c = cell.Interior.Color
    f = RGB(255, 153, 0)
        For a = 1 To 15
            With cell.Interior
                If .Color = f Then .Color = c Else .Color = f
            End With
            Application.Wait (Now + TimeValue("00:00:01"))
        Next a
    cell.Interior.Color = c
End Sub
Private Sub flash_turn(cell As Range)
    Dim c, f, a
    c = cell.Interior.Color
    f = RGB(255, 0, 51)
        For a = 1 To 15
            With cell.Interior
                If .Color = f Then .Color = c Else .Color = f
            End With
            Application.Wait (Now + TimeValue("00:00:01"))
        Next a
    cell.Interior.Color = c
End Sub
 
Upvote 0
You can use UNION to combine ranges, (using my original code) like this....

Code: 
Option Explicit
Sub TestIt()
    Dim r As Long, c As Long, rng1 As Range, rng2 As Range, rng3 As Range
    r = 5: c = 4
    
    Set rng1 = Cells(r, c).Offset(, 1).Resize(, 9)
    Set rng2 = Cells(r + 1, c).Offset(, 1).Resize(, 9)
    Set rng3 = Union(rng1, rng2)
    Call flash(rng3)
      
End Sub

But, because your combined range is 2 adjacent rows, so you can get there in one step by resizing in both directions ....
Code: 
Call flash(Cells(r, c).Offset(, 1).Resize[COLOR=#ff0000](2[/COLOR], 9))
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Help to exit VBA upon cancel on input box
Replies
3
Views
490
Domenic
D
E
  • Question Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
519
offthelip
O
R
  • Question Question
VBA , To consolidate two worksheet_chang events or to add events to another one
Replies
0
Views
497
ROUKWA
R
A
  • Question Question
VBA script delete row containing specific text
Replies
1
Views
744
DanteAmor
DanteAmor
C
  • Question Question
Runtime Error only on some sheets - Macro reference "Active Sheet"
Replies
5
Views
552
RoryA
RoryA

Forum statistics

Threads
1,223,162
Messages
6,170,432
Members
452,326
Latest member
johnshaji

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top