Close Workbook when Sheet is inactive

[eli_m]

Hi,

I currently have this regular Module:

Dim DownTime As Date

Sub SetTimer()
    DownTime = Now + TimeValue("00:30:00") ' This sets the timer for 30 minutes of inactivity
    Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=True
End Sub

Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=False
 End Sub

Sub ShutDown()
        MsgBox "Timed out after 30 minutes - Your work has been saved and closed"
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

And I have these in My Sheet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Call StopTimer 'Stop Timeout timer
    Call SetTimer 'Set Timeout timer

If Application.CutCopyMode = False Then
Application.Calculate ' Refresh for Grey Line
End If
End Sub

Private Sub Worksheet_Calculate()

    Call StopTimer 'Stop Timeout timer
    Call SetTimer 'Set Timeout timer

' Ignore Errors after Sorting
Dim r As Range: Set r = Range("A2:AW200")
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

All is working fine and the Workbook closes after 30 minutes.
I want to make it when I am on another sheet that it doesn't close.

I tried stopping the time with the below code but with no success:

Private Sub Worksheet_Activate()
   Call StopTimer 'Stop Timeout timer
  ThisWorkbook.RefreshAll ' Auto Refresh Pivot Tables
 
On Error Resume Next

End Sub

Any help would be great!

Thanks in advance

 

[Georgiboy]

Might be one for 'Worksheet_Deactivate':

Private Sub Worksheet_Deactivate()
    Call StopTimer
End Sub

 

[eli_m]

Might be one for 'Worksheet_Deactivate':

Private Sub Worksheet_Deactivate()
    Call StopTimer
End Sub

Sadly this didnt work either. While I am on another sheet it runs the timeout module. Is there an IF command I can use? eg.
If on Sheet 'Blahblah' then the timeout module runs?

 

[johnnyL]

@eli_m I am a bit confused on what your motive is here.

Are you saying that you only want to close the workbook if a particular active sheet is left inactive of inactivity, but as long as another sheet in the same workbook is the active sheet, you don't care how long the workbook is left open?

 

[eli_m]

@eli_m I am a bit confused on what your motive is here.

Are you saying that you only want to close the workbook if a particular active sheet is left inactive of inactivity, but as long as another sheet in the same workbook is the active sheet, you don't care how long the workbook is left open?

Hi again johnnyL - That is correct.

I have about 5 sheets on my Workbook:

I want sheet named 'IPS' to be the sheet where if inactive for 30 minutes it shuts down the whole workbook.

If I am on any other sheet I want it to keep the workbook open indefinitely

 

[johnnyL]

Ok, I am curious to what your logic is there, if you don't mind me asking? I am sure what you say you want to do can be done, it just befuddles me why you would want to do that.

 

[eli_m]

Ok, I am curious to what your logic is there, if you don't mind me asking? I am sure what you say you want to do can be done, it just befuddles me why you would want to do that.

Haha I don't blame you: I am the owner of the workbook - its shared on OneDrive so everyone in my team can access it.
My team members leave the workbook open for hours at a time and sometimes it causes sync issues with OneDrive. The time out has helped completely with this issue.
They only use the Sheet called "IPS" only.

I don't want the sheet to kick me out because I use it all day long and use the other sheets more that the 'IPS' sheet.

I've asked them to close the workbook when not in use but its been 2 years and its hard to teach an old dog new tricks and they never close it.

It's fustrating being the owner of your own workbook and not being able to sync due to multiple people having it opened. One person even left their laptop on all weekend and I wasn't able to sync until 3 days later.

I wish Microsoft had a kick user function but they don't so the timeout is the way to go

 

[johnnyL]

Oki Doki, I will try to take a look at this situation after I get some sleep, If none else chimes in.

 

[Georgiboy]

In the worksheet module on the sheet you want to use to close the workbook:

Option Explicit

Private Sub Worksheet_Activate()
    Call StartTimer
End Sub

Private Sub Worksheet_Deactivate()
    Call StopTimer
End Sub

In the ThisWorkbook module: (you can change the 'Sheet1.Name' part to the sheet that will close the workbook)

Option Explicit

Private Sub Workbook_Open()
    If ActiveSheet.Name = Sheet1.Name Then
        Call StartTimer
    End If
End Sub

In a standard module:

Option Explicit

Public DownTime As Double

Sub StartTimer()
    DownTime = Now + TimeSerial(0, 0, 10)
    Application.OnTime DownTime, "ShutDown"
End Sub

Sub StopTimer()
    Application.OnTime DownTime, "ShutDown", , False
 End Sub

Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
    MsgBox "Timed out after 10 seconds - Your work has been saved and closed"
End Sub

I have amended the time to be 10 seconds but you can amend that in the 'TimeSerial(0, 0, 10)' part

 

[eli_m]

In the worksheet module on the sheet you want to use to close the workbook:

Option Explicit

Private Sub Worksheet_Activate()
    Call StartTimer
End Sub

Private Sub Worksheet_Deactivate()
    Call StopTimer
End Sub

In the ThisWorkbook module: (you can change the 'Sheet1.Name' part to the sheet that will close the workbook)

Option Explicit

Private Sub Workbook_Open()
    If ActiveSheet.Name = Sheet1.Name Then
        Call StartTimer
    End If
End Sub

In a standard module:

Option Explicit

Public DownTime As Double

Sub StartTimer()
    DownTime = Now + TimeSerial(0, 0, 10)
    Application.OnTime DownTime, "ShutDown"
End Sub

Sub StopTimer()
    Application.OnTime DownTime, "ShutDown", , False
 End Sub

Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
    MsgBox "Timed out after 10 seconds - Your work has been saved and closed"
End Sub

I have amended the time to be 10 seconds but you can amend that in the 'TimeSerial(0, 0, 10)' part

Thanks for that but I am getting this error:

For:

Also the Sheet I want to close the workbook is:

Is the name "Sheet1" or "IPS Cases" ?


My codes are:

Sheet1 (IPS Cases) [the sheet I want to close the work book]:

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

Call StartTimer 'Start Timeout timer

Dim r As Range: Set r = Range("A2:AW200")
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
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://test.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:AW"))
    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:AW200")
    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

Private Sub Worksheet_Calculate()

' Ignore Errors after Sorting
Dim r As Range: Set r = Range("A2:AW200")
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

ThisWorkBook:

Option Explicit
Private Sub Workbook_Open()

    If ActiveSheet.Name = Sheet1.Name Then
        Call StartTimer 'Start Timeout timer
    End If
   
   
  Dim cel As Range
 
  Application.ScreenUpdating = False
  ThisWorkbook.RefreshAll
  With Sheets("IPS Cases")
    On Error Resume Next
    ThisWorkbook.Sheets("IPS Cases").Range("B2").Sort Key1:=ThisWorkbook.Sheets("IPS Cases").Range("B3"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
    On Error GoTo 0
    For Each cel In .Range("A2:AR200")
      With cel
        .Errors(8).Ignore = True
        .Errors(9).Ignore = True
        .Errors(6).Ignore = True
      End With
    Next cel
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopTimer 'Stop Timeout timer before closing
End Sub

Regular Module:

Option Explicit
Public DownTime As Double

Sub StartTimer()
    DownTime = Now + TimeSerial(0, 0, 30)
    Application.OnTime DownTime, "ShutDown"
End Sub

Sub StopTimer()
    Application.OnTime DownTime, "ShutDown", , False
 End Sub

Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
    MsgBox "Timed out after 30 seconds - Your work has been saved and closed"
End Sub

Thanks again - hopefully you can see the errors I'm making