Sheet swap macro stops swapping after period of time, where is the problem?

Hi everyone!

I use this to show many kind of information in a warehouse.. but it stops somehow from time to time. Please help me find the problem! Thank you!

I need to run this 24/7 on dedicated order displays.

 
Option Explicit

Const s1 As String = "display B"
Const s2 As String = "line delivery"
Dim dtRun As Date
Dim dtInterval As Date
Dim dtEndTime As Date

Sub SwapSheets()
    'run this to start swapping sheets
    dtInterval = TimeSerial(0, 0, 15) 'sets the frequency of swapping sheets
    dtRun = Now() + dtInterval
    
    If ActiveSheet.Name = s1 Then
        Worksheets(s2).Activate
    Else
        Worksheets(s1).Activate
    End If
    
    Application.OnTime dtRun, "SwapSheets", dtEndTime, True
End Sub

Sub StopSwap()
    'run this to manually stop sheets swapping
    On Error Resume Next
    Application.OnTime dtRun, "SwapSheets", dtEndTime, False
End Sub

Unfortunately your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here



(This thread should receive no further responses until this moderation request is fulfilled, as per Forum Rule 7)

Hi Lazlo

Here is some code I did recently for someone else on the forum. For testing purposes I've adapted it to swap worksheets every 5 seconds, change the IntSeconds from 5 seconds to whatever you like.

I can't upload an attachment because the site is still stuffed. Download it from the Dropbox link below

Cheers

https://www.dropbox.com/s/pqleg5ctz4...pVBA.xlsb?dl=0

Option Explicit

Public RunWhen As Double
Public Const IntSeconds As Long = 5 ' 5 seconds
Public Const RunWhat As String = "SwapSheets"
Public Const S1 As String = "Display B"
Public Const S2 As String = "Line Delivery"

Sub StartCountDown()

    RunWhen = Now + TimeSerial(0, 0, IntSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=RunWhat, _
        Schedule:=True
        
End Sub
Sub SwapSheets()

    If ActiveSheet.Name = S1 Then
        Worksheets(S2).Activate
    Else
        Worksheets(S1).Activate
    End If

    StartCountDown  ' Reschedule the procedure
    
End Sub

Sub StopCountDown()

    On Error Resume Next
    
    Application.OnTime EarliestTime:=RunWhen, Procedure:=RunWhat, _
        Schedule:=False
            
    On Error GoTo 0
    
Exit Sub

End Sub