Schedule code to run at a set time and then at intervals thereafter

[Poundland]

Hi Guys,

I am trying to write some code that will trigger a code routine to run at a set time each day and then at 30 minute intervals thereafter.

I have tried using the Application.OnTime function with a start time and intervals but it only runs once at the specified time and not at the intervals.

Can you point me in the right direction as to what I am doing wrong.

My full code is below;


Dim TimeToRun
Sub Schedulemacro()
TimeToRun = TimeValue("14:20") + TimeValue("00:30:00")
Application.OnTime TimeToRun, "allemailsandcompile"
End Sub

Sub Schedulemacroend()
On Error Resume Next
Application.OnTime TimeToRun, "allemailsandcompile", , False
End Sub


Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date
pdat = Format(Now, "dd/mm/yyyy")
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Stock Ledger.xlsx", vbDirectory) = vbNullString Then
Else
Call stockledger
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Availability Measurement by SKU.xlsx", vbDirectory) = vbNullString Then
Else
Call SkuAvailability
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Availability Measurement by Store.xlsx", vbDirectory) = vbNullString Then
Else
Call storeavailability
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability Summary - Summary by DC-AWR.pdf", vbDirectory) = vbNullString Then
Else
Call dailyrangesummary
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability.xlsx", vbDirectory) = vbNullString Then
Else
Call skurangefullversion
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials Overstock " & Format(pdat, "dd.mm.yyyy") & ".xlsx", vbDirectory) = vbNullString Then
Else
Call awrreports
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials at Risk " & Format(pdat, "dd.mm.yyyy") & ".xlsm", vbDirectory) = vbNullString Then
Else
Call awrreports
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Supplier to DC Delivery Issues " & Format(pdat - 1, "ddmmyy") & ".xlsx", vbDirectory) = vbNullString Then
Call Schedulemacroend
Exit Sub
Else
Call dcfaileddelivery
End If
Call Schedulemacro

End Sub

[Paul_Hossler]

I think to have it run at 'intervals', each time you run it you need to re-schedule it for the next interval

Some thoughts ...




Option Explicit
Dim TimeToRun As String
Dim KeepRunning As Boolean


'schedule macro for 14:20
Sub ScheduleMacroStart()
TimeToRun = TimeValue("14:20")
KeepRunning = True
Application.OnTime TimeToRun, "allemailsandcompile"
End Sub

'schedule macro again for TimeToRun
Sub ScheduleMacroRerun()
If Not KeepRunning Then Exit Sub
Application.OnTime TimeToRun, "allemailsandcompile"
End Sub

'remove macro from schedule
Sub ScheduleMacroEnd()
KeepRunning = False
Application.OnTime TimeToRun, "allemailsandcompile", , False
End Sub


Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date

'........

'rerun the macro in 30 min unless calceled with ScheduleMacroEnd
TimeToRun = Now + TimeValue("00:30:00")
Call ScheduleMacroRerun

End Sub

[Poundland]

Thanks Paul, I will test the code in the morning and let you know. Thanks for the speedy answer..

[Poundland]

Paul,

I tested the code this morning, it ran when scheduled but did not run again at the interval times. Any other suggestions?

[GTO]

If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Supplier to DC Delivery Issues " & Format(pdat - 1, "ddmmyy") & ".xlsx", vbDirectory) = vbNullString Then
Call Schedulemacroend
Exit Sub
Else
Call dcfaileddelivery
End If
Call Schedulemacro


Just to note that if any of the other procedures called end the code somehow, or, we exit the sub early, it would of course miss scheduling the next OnTime.

Mark

[Poundland]

Mark,

The only Exit Sub code line is on the last file check, and this will always be the last file that will be captured in the folder so will naturally end the scheduled run. I have checked over the other procedures and there is nothing that I can see that would cause the Schedule run to end.

[GTO]

Here is Paul's code simply with a message box tacked in. Try it by itself before applying it to your project (it runs fine for me) and maybe it will become apparent as to what step was altered/missed?



Option Explicit
Dim TimeToRun As String
Dim KeepRunning As Boolean


Sub ScheduleMacroStart()
'// NOTE: for testing, pick a minute or two from NOW() and run it.//
TimeToRun = TimeValue("6:19")
KeepRunning = True
Application.OnTime TimeToRun, "allemailsandcompile"
End Sub

'schedule macro again for TimeToRun
Sub ScheduleMacroRerun()
If Not KeepRunning Then Exit Sub
Application.OnTime TimeToRun, "allemailsandcompile"
End Sub

'remove macro from schedule
Sub ScheduleMacroEnd()
KeepRunning = False
Application.OnTime TimeToRun, "allemailsandcompile", , False
End Sub


Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date

'........

'rerun the macro in 30 min unless calceled with ScheduleMacroEnd
KeepRunning = (MsgBox("Keep running?", vbQuestion Or vbYesNo, vbNullString) = vbYes)
TimeToRun = Now + TimeValue("00:00:06")
Debug.Print ">" & TimeToRun & "<"
Call ScheduleMacroRerun

End Sub

[Paul_Hossler]

One easy thing to try is to put the Rerun at the top and see if it it works,

If that doesn't then I can play around with it some more by commenting out things



Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date
'-------------------- move to top
'rerun the macro in 30 min unless calceled with ScheduleMacroEnd
TimeToRun = Now + TimeValue("00:30:00")
Call ScheduleMacroRerun


'........


End Sub

[Poundland]

Paul, Mark,

I tested the code on something simple and it still would not work, it ran at the scheduled time ok but did not run again.


Option Explicit
Dim TimeToRun As String
Dim KeepRunning As Boolean
Sub ScheduleMacroStart()
TimeToRun = TimeValue("15:00")
KeepRunning = True
Application.OnTime TimeToRun, "checkbox"
End Sub

'schedule macro again for TimeToRun
Sub ScheduleMacroRerun()
If Not KeepRunning Then Exit Sub
Application.OnTime TimeToRun, "checkbox"
End Sub

'remove macro from schedule
Sub ScheduleMacroEnd()
KeepRunning = False
Application.OnTime TimeToRun, "checkbox", , False
End Sub
Sub checkbox()
MsgBox "still running"
TimeToRun = Now + TimeValue("00:00:10")
Call ScheduleMacroRerun
End Sub

[Poundland]

Mark,

I tried your code in a new workbook, same outcome, it ran at the scheduled time but would not run at the intervals.

[Paul_Hossler]

OK, I sort of reverted to the way I do it. Sorry, but I tried to do it your way, but maybe this will get you started if you want to make changes

I think that your TImeToRun as not being maintained between submission since it was a VBA variable. You could store it someplace like the registry, but the example below is probably easier

16353


I started it with ScheduleMacroStart, let it reschedule itself 3-4 times, and stopped it with ScheduleMacroStop




Option Explicit
Dim KeepRunning As Boolean

Sub ScheduleMacroStart()
Debug.Print "started running -- " & Now
KeepRunning = True
Application.OnTime Now + TimeValue("00.00:10"), "checkbox"
End Sub

'remove macro from schedule
Sub ScheduleMacroEnd()
Debug.Print "stopped running -- " & Now
KeepRunning = False
End Sub

Sub checkbox()
If KeepRunning Then
Application.OnTime Now + TimeValue("00:00:05"), "checkbox"
Debug.Print "still running -- " & Now
Else
Debug.Print "exiting -- " & Now
End If
End Sub

[Poundland]

Paul,

I will check this new code out on Monday and let you know how I get on. Thanks for your help buddy.

[SamT]

If you are closing this workbook between runs, then TimeToRun is lost.
If that is the case, then either create a Custom Workbook Property
OR
Insert a Very hidden Sheet("RequiredForVBA")

Then
Dim TimeToRun As Range
Set TimeToRun = Sheets("RequiredForVBA").Range("A1")
OR
Name a Range on RequiredForVBA = "TimeToRun"

Then set that Custom Property or Range to the required Time to run when rescheduling and set it to "" when canceling the Schedule.

You don't need the Boolean "KeepRunning" Since KeepRunning is always True until you Cancel the Schedule.


Sub Schedulemacro()
With Sheets("RequiredForVBA").Range("TimeToRun")
.Value = Date + TimeValue("14:20")
Application.OnTime .Value, "allemailsandcompile"
End With
End Sub

Sub ScheduleMacroEnd()
With Sheets("RequiredForVBA").Range("TimeToRun")
Application.OnTime .Value, "allemailsandcompile" , , False
.Value = ""
End With
End Sub

ub allemailsandcompile() ' checks to see if all the emails have been captured
'........

With Sheets("RequiredForVBA").Range("TimeToRun")
.Value = .Value + TimeValue("00:30:00")
Application.OnTime .Value, "allemailsandcompile"
End With

End Sub

[Paul_Hossler]

The reason I like to use a KeepRunning Boolean is because the way I read the Help, you need to know the Execute time as well as the procedure name, and I usually don't have the time the current instance was started, accurate to a second, for (repeating) procedures that run at intervals

Now if I submitted an OnTime procedure for 17:00:00 (non-repeating) which has not executed yet, then the Schedule := False would be the way I'd go




https://msdn.microsoft.com/en-us/library/office/ff196165.aspx

16356

[SamT]

I usually don't have the time the current instance was started, accurate to a second, for (repeating) procedures that run at intervals
The only way to cancel an ONTime event is to know the Scheduled Run Time.

The actual time the procedure is started in usually not the Scheduled Time and is not relevant.

[Paul_Hossler]

I understand that part, but if I have a OnTime procedure that launches itself at (Say) Now+15min, the Scheduled Run Time is not available unless I store it some where

1. OnTime Start=17:00 - launches 2 minute task which re-launches itself at Now+15 so Start Time = 17:17

2. OnTime Start=17:17 - launches 2 minute task which re-launches itself at Now+15 so Start Time = 17:34

3. OnTime Start=17:34 - launches 2 minute task which re-launches itself at Now+15 so Start Time = 17:51


etc.

I could store the 17:51 and cancel the task running since I know the task name and the Scheduled Run Time, or

but I just set a Get Out flag so that when the 17:51 task kicks off, it just says goodbye and doesn't resubmit itself.

I really don't know which way is better, although I find the second way less complicated (maybe since I'm used to it)

[SamT]

I see. You just allow the last scheduled task to run instead of canceling it. That's a pretty good way to do it when possible.

You still have to store a variable somewhere.



Sub Schedulemacro()

Sheets("RequiredForVBA").Range("KeepRunning").Value = "True"
Application.OnTime Date + TimeValue("14:20:00"), "allemailsandcompile"
End Sub

Sub ScheduleMacroEnd()

Sheets("RequiredForVBA").Range("KeepRunning").Value = "False"
End Sub

Sub allemailsandcompile() ' checks to see if all the emails have been captured
'........

If Sheets("RequiredForVBA").Range("KeepRunning") Then
Application.OnTime Now + TimeValue("00:30:00") , "allemailsandcompile"
End If
End Sub

IMO, it would be more elegant to use a custom Workbook Property.

[Paul_Hossler]

IMO, it would be more elegant to use a custom Workbook Property

I agree

I'll update the way I do things with OnTime

Thanks for the suggestion

[Poundland]

Paul,

I have adapted your latest code and this now works.

I added a start time on the first code line to auto start and then to keep running at intervals until all emails have been compiled.

Thank you for your help, both yourself and SamT.

Code below;


Option Explicit
Dim KeepRunning As Boolean

Sub ScheduleMacroStart()
'Debug.Print "started running -- " & Now
KeepRunning = True
Application.OnTime Date + TimeValue("12:05"), "allemailsandcompile"
End Sub

'remove macro from schedule
Sub ScheduleMacroEnd()
'Debug.Print "stopped running -- " & Now
KeepRunning = False
End Sub


End Sub
Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date

pdat = Format(Now, "dd/mm/yyyy")
'MsgBox "macro running"
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Stock Ledger.xlsx", vbDirectory) = vbNullString Then
Else
Call stockledger
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Availability Measurement by SKU.xlsx", vbDirectory) = vbNullString Then
Else
Call SkuAvailability
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Availability Measurement by Store.xlsx", vbDirectory) = vbNullString Then
Else
Call storeavailability
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability Summary - Summary by DC-AWR.pdf", vbDirectory) = vbNullString Then
Else
Call dailyrangesummary
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " SKU Range Daily Availability.xlsx", vbDirectory) = vbNullString Then
Else
Call skurangefullversion
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials Overstock " & Format(pdat, "dd.mm.yyyy") & ".xlsx", vbDirectory) = vbNullString Then
Else
Call awrreports
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Essentials at Risk " & Format(pdat, "dd.mm.yyyy") & ".xlsm", vbDirectory) = vbNullString Then
Else
Call awrreports
End If
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Supplier to DC Delivery Issues " & Format(pdat, "ddmmyy") & ".xlsx", vbDirectory) = vbNullString Then
Call ScheduleMacroEnd
'Exit Sub
Else
Call dcfaileddelivery
End If



Application.OnTime Now + TimeValue("00:00:10"), "allemailsandcompile"

End Sub

[Poundland]

I marked this thread too soon as being SOLVED, unfortunately the code is still not working correctly as I would expect.

I now have the opposite issue as before whereby the code keeps running even when the conditions are met and the ScheduleMacroEnd routine is run.

I have tried moving the
Application.OnTime Now + TimeValue("00:00:10"), "allemailsandcompile" which is at the end of the allemailsandcompile routine to the start of the routine but it has now effect.


Any ideas as to why it would keep doing this?

16369

[Poundland]

16368

[GTO]

Removing any sensitive data, can you attach a workbook with exactly how you have it implemented?

[Poundland]

16370

Attached is the workbook, the routines can be found in Module 1

[Paul_Hossler]

If you turn off the KeepRunning flag, you don't want the sub to run and to re-schedule itself

I'd add the <<<<<<<<<<<< line below so that the sub just exits without running

Application.OnTime Now + TimeValue("00:00:10"), "allemailsandcompile"




Sub allemailsandcompile() ' checks to see if all the emails have been captured
Dim pdat As Date

If Not KeepRunning then Exit Sub '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

pdat = Format(Now, "dd/mm/yyyy")
'MsgBox "macro running"
If Not Dir("P:\H925 Buying\Dashboard Reports\" & Format(pdat, "dd.mm.yyyy") & " Stock Ledger.xlsx", vbDirectory) = vbNullString Then
Else
Call stockledger
End If

....

[Paul_Hossler]

16371

This is the skelton from before

[Poundland]

Thanks Paul, that code line worked.

Thank you for all your help.