VBA UDF function causes excel to "not respond"

Question

I have some very simple code that is causing Excel to crash.

I have debugged the variables as can be seen in the code and they look fine except that after only a few seconds Now() does not change and waitTime does not change - although the times are different from each other ie the time has not moved forward (for example, Now might be stuck at 3:00:05 and waitTime is stuck at 3:00:09).

And application.wait does not wait the 5 seconds I've asked for.

And the cell font color does not change either.

I do not know how to debug any further than this.

In the worksheet "sheet1" I have the following cell entries - in C8 I have a number that I change manually. In D8 I have

=if(C8>25,"yup",startFlash(C8))

And this works fine. It calls the function with no problem. Here is the macro code:

Dim waitTime As Date, stopTime As Date


Function startFlash(x As String)
    Beep
    stopTime = TimeSerial(Hour(Now()), Minute(Now()) + 2, Second(Now()))
    Call sflash
    MsgBox "done"  
End Function

Sub sflash()

    Do While waitTime <= stopTime

        With Sheet1.Range("c8").Font
            If .ColorIndex = 3 Then
              .ColorIndex = 5
             Else
             .ColorIndex = 3
            End If
        End With

        newHour = Hour(Now())
        newMinute = Minute(Now())
        newSecond = Second(Now()) + 5
        waitTime = TimeSerial(newHour, newMinute, newSecond)

        Debug.Print Now(); waitTime; stopTime

        Application.Wait waitTime
    Loop

End Sub

Any suggestions on what code to change to stop Excel from crashing?

Answer 1

Don't rely on time alone if there is any chance of 'walking over' midnight; include the date in your start and stop datetimes.

Option Explicit

Dim waitTime As Date, stopTime As Date

Function startFlash(x As String)
    Beep
    stopTime = Now + TimeSerial(0, 2, 0)
    'Debug.Print stopTime
    Call sflash
    MsgBox "done"
End Function

Sub sflash()

    Do While waitTime <= stopTime

        With Sheet1.Range("c8").Font
            If .ColorIndex = 3 Then
              .ColorIndex = 5
             Else
             .ColorIndex = 3
            End If
        End With

        waitTime = Now + TimeSerial(0, 0, 5)
        'Debug.Print Now; waitTime; stopTime

        Do While Now < waitTime: DoEvents: Loop
    Loop

End Sub

Looping through the DoEvents Function until your times meet is a better method.