Excel vba закрывается через раз

Question

Кто-нибудь знает какой-либо код VBA, который закроет и сохранит файл Excel после задержки?Я попробовал какой-то код kutools, который должен был закрыться только после некоторого времени простоя, но он закрывается без проверки на бездействие.

Answer 1

Вставить в рутинный модуль:

    Sub Reset()
Static SchedSave
    If SchedSave <> 0 Then
    Application.OnTime SchedSave, "SaveWork", , False
    End If
    SchedSave = Now + TimeValue("00:10:00")     '<--- Ten minutes
    Application.OnTime SchedSave, "SaveWork", , True
End Sub

Sub SaveWork()
MsgBox "Run the close workbook macro here."
'ThisWorkbook.Save
'Application.Quit
'ThisWorkbook.Close
End Sub

Вставить в ThisWorkbook:

Private Sub Workbook_Open()
Reset
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Reset
End Sub

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

Таймер запустится автоматически при открытии книги.В настоящее время установлено на 10 минут (можно настроить).Код закрытия макросов был отключен и в настоящее время заменен уведомлением MsgBox.

Answer 2

Вставить в рутинный модуль:

Option Explicit

Const idleTime = 30 'seconds
Dim Start
Sub StartTimer()
Start = Timer
Do While Timer < Start + idleTime
    DoEvents
Loop
'///////////////////////////////////////////////////////
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Step 1: Declare your variables
Dim ws As Worksheet
'Step 2: Unhide the Starting Sheet
Sheets("Sheet1").Visible = xlSheetVisible
'Step 3: Start looping through all worksheets
For Each ws In ThisWorkbook.Worksheets
'Step 4: Check each worksheet name
If ws.Name <> "Sheet1" Then
'Step 5: Hide the sheet
ws.Visible = xlVeryHidden
End If
'Step 6: Loop to next worksheet
Next ws
'Application.ScreenUpdating = True

Range("A1").Select

ThisWorkbook.Save

'Application.DisplayAlerts = True
'//////////////////////////////////////////////////////////
'Application.DisplayAlerts = False
Application.Quit
ActiveWorkbook.Close SaveChanges:=True

Application.DisplayAlerts = True
End Sub

Вставить в ThisWorkbook:

Option Explicit

Private Sub Workbook_Open()
    StartTimer
End Sub

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