Can we restrict Application.OnTime Macro from applying to all workbooks open
Code in This workbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = True
ThisWorkbook.Save
Call StopTimer
Application.EnableEvents = True
End Sub
Private Sub Workbook_Open()
Application.Run "StartTimer"
End Sub
Code In Module 1
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=False
MsgBox "Successful"
End Sub
Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub Save1()
Dim path1 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Workbooks("WE-Final.xlsm").Worksheets("My_Subs").Activate
path1 = "\\ant.amazon.com\dept-as\hyd\hyd1\HR\NA-ERC\ERP Workallocation\Work Extraction- Asc Files\Associate Data\" & Environ("username") & ".xlsx"
If Len(Dir(path1, vbDirectory)) = 0 Then
Set wkb = Workbooks.Add
wkb.SaveCopyAs path1
End If
Set destwb = Workbooks.Open(path1)
Set dest_sheet = destwb.Worksheets("Sheet1")
Set currSheet = ThisWorkbook.Sheets("My_Subs")
dest_sheet.Cells.Delete
currSheet.Cells.Copy _
Destination:=dest_sheet.Cells
destwb.Save
destwb.Close
Worksheets("My_Subs").Activate
ThisWorkbook.Save
MsgBox "Saved"
StartTimer
End Sub
Code in This workbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = True
ThisWorkbook.Save
Call StopTimer
Application.EnableEvents = True
End Sub
Private Sub Workbook_Open()
Application.Run "StartTimer"
End Sub
Code In Module 1
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=False
MsgBox "Successful"
End Sub
Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub Save1()
Dim path1 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Workbooks("WE-Final.xlsm").Worksheets("My_Subs").Activate
path1 = "\\ant.amazon.com\dept-as\hyd\hyd1\HR\NA-ERC\ERP Workallocation\Work Extraction- Asc Files\Associate Data\" & Environ("username") & ".xlsx"
If Len(Dir(path1, vbDirectory)) = 0 Then
Set wkb = Workbooks.Add
wkb.SaveCopyAs path1
End If
Set destwb = Workbooks.Open(path1)
Set dest_sheet = destwb.Worksheets("Sheet1")
Set currSheet = ThisWorkbook.Sheets("My_Subs")
dest_sheet.Cells.Delete
currSheet.Cells.Copy _
Destination:=dest_sheet.Cells
destwb.Save
destwb.Close
Worksheets("My_Subs").Activate
ThisWorkbook.Save
MsgBox "Saved"
StartTimer
End Sub