Save and Close Excel after a 15min inactivity.

[Hopey87]

Hi i am trying to add a macro to save and close excel after a period of 15min of inactivity as a number of people use the excel spreadsheet and leave open which then locks the spreadsheet.

I already have code in Module 1:

Sub InsertAndLockRow()
Dim ws As Worksheet
Dim newRow As Range
Dim oldRow As Range
ActiveSheet.Unprotect

Set ws = ActiveSheet
ws.Rows(10).Insert Shift:=xlDown
Set newRow = ws.Rows(10)
Set oldRow = ws.Rows(11)
oldRow.Locked = True
oldRow.FormulaHidden = True
newRow.Locked = False
Range("A10:E10").Font.Bold = False
With Range("A10:E10").Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
With Range("A10:E10").Interior
.Pattern = xlNone
End With
With Range("C10:E10")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Range("C10:E10").Merge
Rows("10:10").RowHeight = 105
Range("A10").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True
End Sub

 

[Logit]

The following is placed in the ThisWorkbook Module :

Option Explicit


Private Sub Workbook_Open()
    Application.Visible = True
    Idle_Start
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Idle_Start
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Idle_Start
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Idle_Start
End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Idle_Start
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Idle_Start
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    Idle_Start
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Idle_Start
End Sub

Private Sub Workbook_WindowResize(ByVal Wn As Window)
    Idle_Start
End Sub

The following is placed in a Routine Module :

Option Explicit

Public NextTime As Date

Sub Idle_Start()
    Idle_End
    NextTime = Now + TimeValue("00:15:00")  '<---idle time hh:mm:ss
    Application.OnTime NextTime, "MyMacro"
End Sub

Sub Idle_End()
    On Error Resume Next
    Application.OnTime NextTime, "sveClseWB", Schedule:=False
End Sub

Sub sveClseWB()
    
    Application.DisplayAlerts = False
    Application.Visible = False
    Workbooks("SaveNCloseWB.xlsb").Close SaveChanges:=True
    Application.DisplayAlerts = True
    
End Sub

If there is no activity for 15 minutes, the workbook closes and is saved.

Download sample workbook : Internxt Drive – Private & Secure Cloud Storage

 

[Hopey87]

Hi Thank you, but as the time hits the 15mins mark it comes up with an error "cannot run the macro "FILE NAME". The macro may not be available in this workbook or all macros may be disabled."

 

[Logit]

Post the following into the ThisWorkbook Module:

Option Explicit

Private Sub Workbook_Open()
Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
Application.DisplayAlerts = False
ThisWorkbook.Saved = True
Application.Visible = False
Application.Quit
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
Call StopTimer
Call SetTimer
End Sub


Paste the following into a Regular Module :


Option Explicit


Dim DownTime As Date

Sub SetTimer()
DownTime = Now + TimeValue("00:15:00") ''<--- change time to close here
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()

Application.DisplayAlerts = False
With ThisWorkbook
.Saved = True
.Close
End With
End Sub