Conditional Flashing Cells in XL2K

Well,

The first problem was to call an OnTime at the exact same moment (as explained in this article), which is why I used a workaround, which made the workbook be re-opened when it was closed, while a OnTime event was still scheduled. The correction is included in the code. But you will need to add the line Sheet1.Activate to the before_close event of your workbook:


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheet1.Activate
End Sub

The second problem, is because in case of empy scores, all teams are in first place, and the search for 2nd and 3rd place is causing errors. The same of course, as you noticed yourself, applies to 15 equal scores. This is now dealed with by error handlers.

Code follows (the result sheet part)

calacuccia

'Code

Dim nextTime As Double


Private Sub Worksheet_Activate()
goFlashing
End Sub


Private Sub Worksheet_Deactivate()
On Error Resume Next
'Error loop necessary, because it is unknown which of both procedures is
'scheduled at this point, so the error caused by 1 of 2 statements below is
'expected and normal
Application.OnTime nextTime, "The_Game.xls!Sheet2.BackWhite", , False
Application.OnTime nextTime, "The_Game.xls!Sheet2.goFlashing", , False
On Error GoTo 0
stopFlashing
End Sub

Sub goFlashing()
Dim totals As Range, c As Range
Dim actTotal As Double
Dim firstRow As Integer, i As Integer
Dim aRank As Integer, nEquals As Integer
Dim zFirst(), zSecond(), zThird() As Integer
Dim Range1 As Range, Range2 As Range, Range3 As Range
Set totals = Me.Range("W3:W17") 'You know this can be changer, fixed for the moment
'Look for first place teams (put them in matrix zFirst)
aRank = 1
'Error loop to deal with all empty data ""
On Error Resume Next
actTotal = Application.WorksheetFunction.Large(totals, aRank)
If Err.Number = 1004 Then Exit Sub
Err.Clear
On Error GoTo 0
Set c = totals.Find(What:=actTotal, LookIn:=xlValues, Lookat:=xlWhole)
firstRow = c.Row
ReDim Preserve zFirst(0)
zFirst(0) = 0
Do
   ReDim Preserve zFirst(UBound(zFirst) + 1)
   zFirst(UBound(zFirst)) = c.Row
   Set c = totals.FindNext(c)
Loop While Not c Is Nothing And c.Row <> firstRow
Set Range1 = Me.Range("B" & zFirst(1) & ":W" & zFirst(1))
For i = 2 To UBound(zFirst)
   Set Range1 = Union(Range1, Me.Range("B" & zFirst(i) & ":W" & zFirst(i)))
Next i
'Look for second place teams (put them in matrix zSecond)
aRank = aRank + UBound(zFirst)
'Error handler used to detect cases with only no. 1 position teams
On Error Resume Next
actTotal = Application.WorksheetFunction.Large(totals, aRank)
If Err.Number = 1004 Then
    Err.Clear
    On Error GoTo 0
    GoTo flashPart
End If
On Error GoTo 0
Set c = totals.Find(What:=actTotal, LookIn:=xlValues, Lookat:=xlWhole)
firstRow = c.Row
ReDim Preserve zSecond(0)
zSecond(0) = 0
Do
   ReDim Preserve zSecond(UBound(zSecond) + 1)
   zSecond(UBound(zSecond)) = c.Row
   Set c = totals.FindNext(c)
Loop While Not c Is Nothing And c.Row <> firstRow
Set Range2 = Me.Range("B" & zSecond(1) & ":W" & zSecond(1))
For i = 2 To UBound(zSecond)
   Set Range2 = Union(Range2, Me.Range("B" & zSecond(i) & ":W" & zSecond(i)))
Next i
'Look for third place teams (put them in matrix zThird)
aRank = aRank + UBound(zSecond)
'Error handler used to detect cases with only no. 1 position teams
On Error Resume Next
actTotal = Application.WorksheetFunction.Large(totals, aRank)
If Err.Number = 1004 Then
    Err.Clear
    On Error GoTo 0
    GoTo flashPart
End If
On Error GoTo 0
Set c = totals.Find(What:=actTotal, LookIn:=xlValues, Lookat:=xlWhole)
firstRow = c.Row
ReDim Preserve zThird(0)
zThird(0) = 0
Do
   ReDim Preserve zThird(UBound(zThird) + 1)
   zThird(UBound(zThird)) = c.Row
   Set c = totals.FindNext(c)
Loop While Not c Is Nothing And c.Row <> firstRow
Set Range3 = Me.Range("B" & zThird(1) & ":W" & zThird(1))
For i = 2 To UBound(zThird)
   Set Range3 = Union(Range3, Me.Range("B" & zThird(i) & ":W" & zThird(i)))
Next i
'Now make rows stored in zFirst flash
flashPart:
Range1.Interior.ColorIndex = 34
'Same to rows from zSecond
On Error Resume Next
'This part is also handled, to prevent the case of all no. 1 position teams
Range2.Interior.ColorIndex = 35
'and for rows in zThird
Range3.Interior.ColorIndex = 36
Err.Clear
On Error GoTo 0
nextTime = Now() + TimeValue("00:00:01")
Application.OnTime nextTime, "The_Game.xls!Sheet2.BackWhite"
End Sub

Sub stopFlashing()
Me.Range("B3:W17").Interior.ColorIndex = -4142
End Sub

Sub BackWhite()
stopFlashing
nextTime = Now() + TimeValue("00:00:01")
Application.OnTime nextTime, "The_Game.xls!Sheet2.goFlashing"
End Sub