Auto close spreadsheet timer not working correctly

[eli_m]

Hi all,

I have this Timeout_Module:

Option Explicit
Public DownTime As Double
Sub StartTimer()
    DownTime = Now + TimeSerial(0, 30, 0)
    Application.OnTime DownTime, "ShutDown"
End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime DownTime, "ShutDown", , False
 End Sub
Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

It seems to work fine but after 30 minutes it closes my spreadsheet regardless of:
Call StopTimer
Call StartTimer

Restarting the timer the below code:

Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()

Call StartTimer 'Start Timeout timer

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

Private Sub Worksheet_Deactivate()
    Call StopTimer 'Stop Timeout timer so it can stay open when on other sheets
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate ' Refresh for Grey Line
End If
Call StopTimer 'Stop Timeout timer
Call StartTimer 'Restart Timeout timer
End Sub

Private Sub Worksheet_Calculate()

' Ignore Errors after Sorting
Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
    With cel
        .Errors(8).Ignore = True 'Data Validation Error
        .Errors(9).Ignore = True 'Inconsistent Error
        .Errors(6).Ignore = True 'Lock Error
    End With
Next cel
Call StopTimer 'Stop Timeout timer
Call StartTimer 'Restart Timeout timer
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://cases.com/ui/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        If Target.Value <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete
        End If
 
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AQ"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If


    'Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AQ200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel
    
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
    

End Sub

Even though I am entering text or clicking around the spreadsheet will still close after 30 minutes intermittently.
I can't seem to put a finger on why it is doing this.


Any help would be greatly appreciated!

Thank you in advance

 

[eli_m]

I have discovered what the problem is, The code you adding to the workbook open is correct and does work , the probelm is the check on the time in the check timere module. I put a few msgbox in that routine and checked it out. The probelm arise because I my efforts to "bracket" the time it triggers which is never going to be accurate. this code will catch the close event but may take 4 minutes instead of 2. Having identified the probelm perhaps you can fix it to your satisfaction:
My checktimer:

Sub checktimer()
  deltalimit = (TimeSerial(0, 1, 59))
    deltatime = Now() - Lastchange
   MsgBox "checktimer runs " & deltatime
  
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 2, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 2, 0))
    End If
    MsgBox NextTime
    Application.OnTime NextTime, "checktimer"
    End If
End Sub

The strangest thing is happening. The timer seems to work and the spreadsheet closes BUT then opens up again straight away by itself

This is my code now:

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Sub checktimer()
  deltalimit = (TimeSerial(0, 0, 59))
    deltatime = Now() - Lastchange
   
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 1, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 1, 0))
    End If

    Application.OnTime NextTime, "checktimer"
    End If
End Sub
Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

If I run the Shutdown macro by itself there is no issues and it stays close.

What could be causing it to close then reopen staright away?

 

[offthelip]

It would appear that there is still an application.ontime event running which means you need to cancel it before closing the the workbook, try adding this tothe shutdown routine, in order to cancle the timer you do need to know what time was used to set it, hopefully that is stored in "Nexttime":

Sub ShutDown()
Application.OnTime NextTime, "checktimer", False       'add this line , hoepfully it will cancel the timer
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

 

[eli_m]

It would appear that there is still an application.ontime event running which means you need to cancel it before closing the the workbook, try adding this tothe shutdown routine, in order to cancle the timer you do need to know what time was used to set it, hopefully that is stored in "Nexttime":

Sub ShutDown()
Application.OnTime NextTime, "checktimer", False       'add this line , hoepfully it will cancel the timer
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

Sadly I can see it closing and then opening itself back up again. Could there be a mix up with "checktime" and "checktimer":

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Sub checktimer()
  deltalimit = (TimeSerial(0, 0, 59))
    deltatime = Now() - Lastchange
   
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 1, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 1, 0))
    End If

    Application.OnTime NextTime, "checktimer"
    End If
End Sub
Sub ShutDown()
Application.OnTime NextTime, "checktimer", False
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

 

[offthelip]

I have just checked it out on my computer and it seems to work fine, I put some debug code using column M and N, (change these if they are not spare in your worksheet) in where recorded wat time checktimer was called and what time it ran the reset code. This appears tobe correct. I think one thing you might not have realised is that to stop the timers from firing you have to completely exit EXCEL i.e close ALL workbooks. SO try that and just open the one workbook you are testing.

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Public Rowcount
Public rowcount1
Sub checktimer()
    If Rowcount < 1 Then Rowcount = 1
    Range(Cells(Rowcount, 14), Cells(Rowcount, 14)) = Now()
    Rowcount = Rowcount + 1
    deltalimit = (TimeSerial(0, 1, 59))
    deltatime = Now() - Lastchange
 '   MsgBox "checktimer runs " & deltatime
   
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 2, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 2, 0))
    End If
'    MsgBox NextTime
    If rowcount1 < 1 Then rowcount1 = 1
    Range(Cells(rowcount1, 13), Cells(rowcount1, 13)) = NextTime
    rowcount1 = rowcount1 + 1
    Application.OnTime NextTime, "checktimer"
    End If
End Sub

 

[eli_m]

I have just checked it out on my computer and it seems to work fine, I put some debug code using column M and N, (change these if they are not spare in your worksheet) in where recorded wat time checktimer was called and what time it ran the reset code. This appears tobe correct. I think one thing you might not have realised is that to stop the timers from firing you have to completely exit EXCEL i.e close ALL workbooks. SO try that and just open the one workbook you are testing.

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Public Rowcount
Public rowcount1
Sub checktimer()
    If Rowcount < 1 Then Rowcount = 1
    Range(Cells(Rowcount, 14), Cells(Rowcount, 14)) = Now()
    Rowcount = Rowcount + 1
    deltalimit = (TimeSerial(0, 1, 59))
    deltatime = Now() - Lastchange
 '   MsgBox "checktimer runs " & deltatime
 
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 2, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 2, 0))
    End If
'    MsgBox NextTime
    If rowcount1 < 1 Then rowcount1 = 1
    Range(Cells(rowcount1, 13), Cells(rowcount1, 13)) = NextTime
    rowcount1 = rowcount1 + 1
    Application.OnTime NextTime, "checktimer"
    End If
End Sub

I have many many columns so I had to change it to 55 and 56 but your code says rows.. shouldn't it be columns?
Either way the document closes and then reopens itself up again - I made a video of it: 20231101_231420000_iOS

When I run the macro it works and doesn't reopen:

Could it be something in the checktimer sub that's trigger that is making the document open up again?

Also, thank you so much for sticking with this and helping me - I feel we are close to solving it

The code I used for that video is:

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Public Rowcount
Public rowcount1
Sub checktimer()
    If Rowcount < 1 Then Rowcount = 1
    Range(Cells(Rowcount, 56), Cells(Rowcount, 56)) = Now()
    Rowcount = Rowcount + 1
    deltalimit = (TimeSerial(0, 1, 59))
    deltatime = Now() - Lastchange
 '   MsgBox "checktimer runs " & deltatime
 
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 2, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 2, 0))
    End If
'    MsgBox NextTime
    If rowcount1 < 1 Then rowcount1 = 1
    Range(Cells(rowcount1, 55), Cells(rowcount1, 55)) = NextTime
    rowcount1 = rowcount1 + 1
    Application.OnTime NextTime, "checktimer"
    End If
End Sub

 

[offthelip]

What do you get in columns 55 and 56? that should tell you if there is an extra checktimer call outstanding. Also did include the code to cancel the timer on shutdown if so you could add a message box there to check that the time for cancelled timer is the same as the outstanding timer on the spreadsheet. You need to debug this because it works OK for me.

 

[eli_m]

What do you get in columns 55 and 56? that should tell you if there is an extra checktimer call outstanding. Also did include the code to cancel the timer on shutdown if so you could add a message box there to check that the time for cancelled timer is the same as the outstanding timer on the spreadsheet. You need to debug this because it works OK for me.

I was thinking it might be the spreadsheet so I made a new blank one with just the code and used your column M and N code but change the time out to one minute.

When the page is activated I get:

A minute later I get:

Everything is showing correctly but the problem is in like the video I posted where the spreadsheet closes as per normal but then a second later it opens it self back up. (video here: 20231101_231420000_iOS)

I've tried running the spreadsheet on another computer and still the same things happens. both Excels are up to date but it seems like an Excel bug or something.

What would make the spreadsheet reopen itself?


I only have this in my sheet:

Option Explicit
Private Sub Worksheet_Activate()
'Start Timeout Timer
checktime = False
Call checktimer
'Check Timeout timer
checktime = True
Lastchange = Now()

End Sub

and this as the module:

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Public Rowcount
Public rowcount1
Sub checktimer()
    If Rowcount < 1 Then Rowcount = 1
    Range(Cells(Rowcount, 14), Cells(Rowcount, 14)) = Now()
    Rowcount = Rowcount + 1
    deltalimit = (TimeSerial(0, 0, 59))
    deltatime = Now() - Lastchange
MsgBox "checktimer runs " & deltatime
   
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 1, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 1, 0))
    End If
MsgBox NextTime
    If rowcount1 < 1 Then rowcount1 = 1
    Range(Cells(rowcount1, 13), Cells(rowcount1, 13)) = NextTime
    rowcount1 = rowcount1 + 1
    Application.OnTime NextTime, "checktimer"
    End If
End Sub
Sub ShutDown()
Application.OnTime NextTime, "checktimer", False
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

 

[eli_m]

I've had a quick google and everyone is saying the timer must not be stopping hence it opening again so I changed it to this and it seems to be working now:

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Sub checktimer()
  deltalimit = (TimeSerial(0, 19, 59))
    deltatime = Now() - Lastchange
   
    If deltatime > deltalimit And checktime Then
    Call DisableTimer
    Exit Sub
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 20, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 20, 0))
    End If

    Application.OnTime NextTime, "checktimer"
    End If
End Sub
Sub DisableTimer()
On Error Resume Next
Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), Procedure:="checktimer", _
Schedule:=False
ActiveWorkbook.Saved = True
Call ShutDown
End Sub

Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub