VBA Sub for recalculating any Workbook/Worksheet/Range at any desired time interval

KeepRecalculatingRange.bas.vb

Attribute VB_Name = "KeepRecalculatingRange"
Option Explicit

' VBA Sub for continuously recalculating any Excel Workbook/Worksheet/Range
' at any desired time interval given in seconds.

' Author: Guido Witt-Dörring
' Created: 2022/11/14
' Updated: 2022/12/02
' License: MIT
'
' ----------------------------------------------------------------
' https://gist.github.com/guwidoe/f248271da14d40a6ec7b44ccca245479
' ----------------------------------------------------------------
'
' Copyright (c) 2022 Guido Witt-Dörring
'
' MIT License:
' Permission is hereby granted, free of charge, to any person obtaining a copy
' of this software and associated documentation files (the "Software"), to
' deal in the Software without restriction, including without limitation the
' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
' sell copies of the Software, and to permit persons to whom the Software is
' furnished to do so, subject to the following conditions:
'
' The above copyright notice and this permission notice shall be included in
' all copies or substantial portions of the Software.
'
' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
' IN THE SOFTWARE.

'*******************************************************************************
'COMMENTS REGARDING THE IMPLEMENTATION:
'   This Sub uses some quite hacky techniques to ensure that all
'   Application.OnTime schedules will be cancelled automatically if

'   1) the Workbook is closed. This is important, because otherwise
'      the scheduled recalculation, implemented through Application.OnTime,
'      can simply reopen the Workbook automatically, as long as the
'      application itself isn't closed.

'   2) the "Stop" button in the VBA-IDE is pressed. This is convenient,
'      as the only other way to cancel all the recalculations would be to
'      manually call KeepRecalculating stopAll:=True because normally, the
'      "Stop" button does not affect Application.OnTime schedules.
'
'   In order for these automatic calls to happen, the code in the Sub
'   'Keep Recalculating' should not be altered! Otherwise, if uninformed
'   changes are made, there is a high likelihood of the application crashing!

'   More information on how this behavior was achieved can be found here:
'   https://codereview.stackexchange.com/q/281341/234277
'*******************************************************************************

'*******************************************************************************
'COMMENTS REGARDING THE USAGE:
'
'   The parameters of the sub are explained in the banner comment for the sub.
'   Usage examples are provided below the code of the sub.
'*******************************************************************************

#If Mac Then
    Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, source As Any, ByVal length As LongPtr) As LongPtr
#Else
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal length As LongPtr)
#End If

'*******************************************************************************
'Sub for recalculating any Workbook/Worksheet/Range at any desired time interval
'Depends on: CopyMemory API
'Author: Guido Witt-Dörring
'Parameters:         Type:                    Meaning:
'Range               Workbook/Worksheet/Range Object to be recalculated
'refreshTimeSeconds  Long                     Time interval between calculations
'schedule            Boolean                  True=Start task, False=Stop task
'stopAll             Boolean                  True=Stop all tasks, False=default
'b, s, a             Strings                  Should never be used!!
'Many thanks to Cristian Buse (https://github.com/cristianbuse/) for his help!
'*******************************************************************************
Public Sub KeepRecalculating(Optional ByRef Range As Object = Nothing, _
                             Optional ByRef refreshTimeSeconds As Long = 1&, _
                             Optional ByRef schedule As Boolean = True, _
                             Optional ByRef stopAll As Boolean = False, _
                             Optional ByRef b As String = "", _
                             Optional ByRef s As String = "", _
                             Optional ByRef a As String = "")
    #Const DEBUGG = False
'Note: All parameters MUST be ByRef, otherwise Excel crashes on state-loss of o!
    Static o As IUnknown, vtbl(0 To 2) As LongPtr, vtblPtr As LongPtr
    '      ^-- o must be the first static variable allocated in this sub!
    If vtblPtr = 0 Then 'KeepRecalculating is set as the Release method of obj o
       vtbl(2) = VBA.Int(AddressOf KeepRecalculating): vtblPtr = VarPtr(vtbl(0))
       CopyMemory ByVal VarPtr(o), VarPtr(vtblPtr), LenB(vtblPtr) 'insert vTable
    End If  'This means, if the object o's state is lost, the Sub will be called
    Static tasks As Collection, task 'one last time. That's useful to do cleanup
    #If Win64 Then 'The following is used to check if Sub was called as Release.
        If VarPtr(o) = VarPtr(schedule) Then '<-- this condition only holds when
    #Else 'o is the first static decl. in this Sub AND Sub was called as Release
        If VarPtr(o) = VarPtr(stopAll) Then '<-- this is the equvalent for 32bit
    #End If '<-Memory alignment differs between 32- and 64bit, hence compiler-if
        If tasks Is Nothing Then Exit Sub '<-- can be reached before tasks init.
        On Error Resume Next
        For Each task In tasks 'Cleanup: Cancel all scheduled ApplicationOnTimes
            Application.OnTime task(1), task(0), , False
            #If DEBUGG Then
                Debug.Print "Cancelled: " & task(0)
            #End If
            tasks.Remove task(0) '
        Next task: Exit Sub 'SUBs PARAMETERS CAN'T BE ACCESSED BEFORE THIS LINE!
    End If 'If execution proceeds past this line on state-loss of o, excel will
    If stopAll Then 'crash, because this Subs parameters are now being accessed.
        If tasks Is Nothing Then Exit Sub '<-- can be reached before tasks init.
        For Each task In tasks '----- Cancel all scheduled recalculations: -----
            Application.OnTime task(1), task(0), , False
            #If DEBUGG Then
                Debug.Print "Cancelled: " & task(0)
            #End If
            tasks.Remove task(0)
        Next task: Exit Sub 'Debug.Print "Cancelled: " & task(0)
    End If '--------------------- Sanitize Inputs: -----------------------------
    If Range Is Nothing And b = "" And s = "" And a = "" Then Exit Sub
    If TypeName(Range) <> "Workbook" And TypeName(Range) <> "Worksheet" And _
    TypeName(Range) <> "Range" And TypeName(Range) <> "Nothing" Then err.Raise 5
    If refreshTimeSeconds < 1 Then err.Raise 5 'this would lead to app freezing.
    If tasks Is Nothing Then Set tasks = New Collection
    If TypeName(Range) = "Workbook" Then b = Range.Name
    If TypeName(Range) = "Worksheet" Then s = Range.Name: b = Range.Parent.Name
    If TypeName(Range) = "Range" Then a = Range.Address(external:=True)

    Dim noError As Boolean, ws As Worksheet, tCalc As Single
    Dim nextExec As Double, macroName As String, wasScheduled As Boolean
    Dim tRefresh As Single: tRefresh = refreshTimeSeconds
    macroName = "'KeepRecalculating , " & Replace(tRefresh, ",", ".") & _
                ", , , """ & Replace(b, "'", "''") & """, """ & _
                Replace(s, "'", "''") & """, """ & Replace(a, "'", "''") & """'"
    If Len(macroName) > 255 Then err.Raise vbObjectError + 9, _
        "KeepRecalculating", "Input parameters lead to marco call of more " & _
        "than 255 characters. 'Application.OnTime' can not deal with this."
    On Error Resume Next
    tasks macroName: wasScheduled = (err.Number = 0)
    On Error GoTo -1: On Error GoTo 0
    Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating  'save the
    Dim dispAlerts As Boolean: dispAlerts = Application.DisplayAlerts '  App-
    Dim calcMode As XlCalculation: calcMode = Application.Calculation 'settings
    If schedule Then '----------- Actual Recalculation Starts Here -------------
        On Error Resume Next
        With Application
            If wasScheduled Then 'If previous tCalc was > 0.5s optimize setting:
                If tasks(macroName)(3) > 0.5 Then .ScreenUpdating = False
                .DisplayAlerts = False: .Calculation = xlCalculationManual
            End If: tCalc = Timer() 'tCalc will be duration of the calculation
            If a <> "" Then 'Calculate only Range with Address a
                .Range(a).Dirty
                .Range(a).Calculate 'App.Range is required because a is external
            ElseIf s <> "" Then 'Calculate only Worksheet s
                With .Workbooks(b).Worksheets(s)
                    If .EnableCalculation Then
                        .EnableCalculation = False
                        .EnableCalculation = True: .Calculate
                    End If
                End With
            ElseIf b <> "" Then 'Calculate entire Workbook b
                For Each ws In Workbooks(b).Worksheets
                    If ws.EnableCalculation Then
                        ws.EnableCalculation = False
                        ws.EnableCalculation = True: ws.Calculate
                    End If
                Next ws
            End If
            tCalc = Timer() - tCalc: If tCalc < 0 Then tCalc = tCalc + 86400!
            If wasScheduled Then 'If previous tCalc was > 0.5s restore setting:
                If tasks(macroName)(3) > 0.5 Then .ScreenUpdating = scrUpdate
                .DisplayAlerts = dispAlerts: .Calculation = calcMode
            End If
        End With
        noError = err.Number = 0: On Error GoTo -1: On Error GoTo 0
        If wasScheduled Then tasks.Remove macroName
        If noError Then 'Reschedule only if no error has occurred during calc.:
            If tCalc > tRefresh Then tRefresh = tCalc
            nextExec = DateAdd("s", tRefresh, Now()) 'At least tCalc seconds!
            tasks.Add VBA.Array(macroName, nextExec, tRefresh, tCalc), macroName
            Application.OnTime nextExec, macroName
            #If DEBUGG Then
                Debug.Print "Scheduled: " & macroName
            #End If
        End If
    Else ' --------- Cancel specific scheduled recalculation: ----------
        If wasScheduled Then
            Application.OnTime tasks(macroName)(1), macroName, , False
            tasks.Remove macroName
            #If DEBUGG Then
                Debug.Print "Cancelled: " & macroName
            #End If
        End If
    End If
End Sub


'Examples:
Private Sub KeepRecalculatingExamples()
    '1) Recalculate the entire workbook once every 10 seconds
    KeepRecalculating ThisWorkbook, 10

    '2) Recalculate Worksheet "Sheet1" every five seconds, in addition to
    '   calculating the entire workbook every 10 seconds from step 1)
    KeepRecalculating ThisWorkbook.Worksheets("Sheet1"), 5

    '3) Stop recalculating the entire workbook once every 10 seconds, but
    '   continue recalculations for Worksheet "Sheet1" from step 2)
    KeepRecalculating ThisWorkbook, 10, False

    '4) Recalculate Worksheet "Sheet1" every three seconds, in addition to the
    '   recalculations already happening every five seconds from step 2)
    KeepRecalculating ThisWorkbook.Worksheets("Sheet1"), 3

    '5) Recalculate the Range "B6:B10" on Worksheet "Sheet1" every second,
    '   in addition to recalculating the entire Worksheet every five, and every
    '   three seconds from the steps 2) and 4)
    KeepRecalculating ThisWorkbook.Worksheets("Sheet1").Range("B6:B10"), 1

    '6) Stop recalculating Worksheet "Sheet1" every five seconds, but continue
    '   recalculating the entire Worksheet every three seconds (from step 4)),
    '   and recalculating the Range("B6:B10") every second from step 5)
    KeepRecalculating ThisWorkbook.Worksheets("Sheet1"), 5, False

    '7) Stop recalculating the Range("B6:B10") on the Worksheet "Sheet1" every
    '   second, but continue recalculating the entire Worksheet every three
    '   seconds from step 4)
    KeepRecalculating ThisWorkbook.Worksheets("Sheet1").Range("B6:B10"), 1, False

    '8) Stop all still running continous recalculation schedules. This will be
    '   done automatically if the Workbook is closed or the "Stop" button in the
    '   VBA-IDE is pressed.
    KeepRecalculating stopAll:=True
End Sub