Excel VBA do while loop is killing performance-CodePudding

I wrote a macro to check if a date is the last day of a month. If so this cell should blink every 1 second, so im calling a do while loop.

I want to start the Sub when I open the worksheet, so I added a Workbook_Open() Sub

Private Sub Workbook_Open()
    Call CellBlink
End Sub

If the date is indeed the last day of the month this sub is getting called as expected. The problem is, that the performance is so bad, that it is nearly impossible to work with this sheet. It almost feels like this loop is getting called multiple times.

Do While Today = EndOfMonth

    CellThatBlinks.Interior.ColorIndex = 3
    Application.Wait (Now   TimeValue("0:00:01"))

    CellThatBlinks.Interior.ColorIndex = 0
    Application.Wait (Now   TimeValue("0:00:01"))

    CellThatBlinks.Interior.ColorIndex = 3

    DoEvents

Loop

I would appreciate some help :)

CodePudding user response：

Using Application.OnTime is a way to loop without blocking execution.

First Name the cell in the Workbook that you want to blink, eg "BlinkCell", using Formulas / Define Name.

Then put this code in a Module (not a Workbook or Worksheet object):

Option Explicit
Dim strLast As String

Public Sub CellBlink()
    Dim rngBlink As Range
      
    If WorksheetFunction.EoMonth(Now, 0) = Int(Now) Then
        Set rngBlink = Range("BlinkCell")
        
        Dim onIndex, offIndex
        onIndex = 3
        offIndex = 0
        
        If rngBlink.Interior.ColorIndex = onIndex Then
            rngBlink.Interior.ColorIndex = offIndex
        Else
            rngBlink.Interior.ColorIndex = onIndex
        End If
        
        strLast = Format(Now   TimeValue("00:00:01"), "hh:mm:ss")
        Application.OnTime strLast, "CellBlink"
    End If
End Sub

Public Sub CancelBlink()
    If Len(strLast) > 0 Then
        Application.OnTime strLast, "CellBlink", Schedule:=False
        Range("BlinkCell").Interior.ColorIndex = 0
    End If
End Sub

and this code in the ThisWorkbook object:

Option Explicit

Private Sub Workbook_Open()
    CellBlink
End Sub

Private Sub Workbook_BeforeClose(Cancel as Boolean) 
    CancelBlink
End Sub

How it works: Once the Workbook_Open event is fired, the global subroutine CellBlink is called. In the sheet, the blinking cell is Name'd "BlinkCell". CellBlink checks whether today's date is the end of month: if it is then the cell colour is toggled (on->off->on etc). Finally, the Application.OnTime function is called to run this same CellBlink macro in one second's time. The time that the macro is schedule to run is saved as a string. Running the CancelBlink macro will terminate the loop until CellBlink is called again.