How to run a macro at a particular time, then re-run it at specified interval and end it at a particular time?

nachiketdp

Board Regular
Joined
Jan 31, 2007
Messages
53
Dear All,

I wish to run an excel macro at a particular time, say 7:00 am and would like to run it at a specified interval, say every hour till a particular time, say 5:00 PM. What could be the appropriate code for it? My start time, end time and interval all three would be variables. But I will be still happy if I come across a code involving constants, at least.

Any help will be truly appreciated! Thanks in advance!

Regards,
Nachiket
 

ParamRay

Well-known Member
Joined
Aug 6, 2014
Messages
1,195
this is kind the pattern you need:

Code:
Dim NextRun As Date


Sub StartSchedule()
' This procedure sets the first run for 07:00
  NextRun = TimeSerial(7, 0, 0)
  Application.OnTime NextRun, "MyMacro"
End Sub


Sub MyMacro()
' ==============================
' Your processing code goes here
' ==============================

' The next part schedules another run in an
' hour's time, but only if it's before 17:00

  If Now() < Date + TimeSerial(17, 0, 0) Then
    NextRun = Now() + TimeSerial(1, 0, 0)
    Application.OnTime NextRun, "MyMacro"
  End If
End Sub


Sub StopSchedule()
' This procedure terminates the schedule
  Application.OnTime NextRun, "MyMacro", , False
  
' Note that the schedule will
' also end once you quit Excel
End Sub
 

nachiketdp

Board Regular
Joined
Jan 31, 2007
Messages
53
Just one query. How should I trigger the startSchedule macro? Should I put it in workbook_open event? Or will it work automatically?
 

nachiketdp

Board Regular
Joined
Jan 31, 2007
Messages
53
Hi ParamRay,

I have one question. I developed my code but I am getting the output twice. In other words, the macro runs twice. I am puzzles as to how this happens. Can you please guide me?

Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' This procedure terminates the schedule
  On Error Resume Next
  Application.OnTime NextRun, "MyMacro", , False
  On Error GoTo 0
' Note that the schedule will
' also end once you quit Excel

End Sub

Private Sub Workbook_Open()
'Sub StartSchedule()
' This procedure sets the first run for 07:00
  
truth_val = Worksheets("Parameters").Cells(8, 39).Value
If truth_val = True Then Exit Sub
  
  start_hr = Worksheets("Parameters").Cells(5, 2)
  start_hr = Val(start_hr)
  start_min = Worksheets("Parameters").Cells(5, 3)
  start_min = Val(start_min)
  
  NextRun = TimeSerial(start_hr, start_min, 0)
  Application.OnTime NextRun, "MyMacro"
'End Sub

End Sub


Sub MyMacro()
' ==============================
' Your processing code goes here
' ==============================


'actual execution
Dim time_stamp As Date, date_stamp As Date

Application.ScreenUpdating = False
othfil = ActiveWorkbook.Name
ThisWorkbook.Activate
Calculate
time_stamp = Worksheets("Parameters").Cells(5, 40)
date_stamp = Worksheets("Parameters").Cells(5, 39)
Lcol = Worksheets("Übersicht").Cells(17, Columns.Count).End(xlToLeft).Column

For i = 2 To Lcol
sheet_no = Worksheets("Übersicht").Cells(17, i)
sheet_ref = "H_" & sheet_no
V1 = Worksheets("Übersicht").Cells(18, i)
V2 = Worksheets("Übersicht").Cells(19, i)
V3 = Worksheets("Übersicht").Cells(20, i)
V4 = Worksheets("Übersicht").Cells(21, i)
V5 = Worksheets("Übersicht").Cells(22, i)
V6 = Worksheets("Übersicht").Cells(23, i)

Lrow = Worksheets(sheet_ref).Cells(Rows.Count, "A").End(xlUp).Row + 1
Worksheets(sheet_ref).Cells(Lrow, 1) = date_stamp
Worksheets(sheet_ref).Cells(Lrow, 2) = time_stamp
Worksheets(sheet_ref).Cells(Lrow, 3) = V1
Worksheets(sheet_ref).Cells(Lrow, 4) = V2
Worksheets(sheet_ref).Cells(Lrow, 5) = V3
Worksheets(sheet_ref).Cells(Lrow, 6) = V4
Worksheets(sheet_ref).Cells(Lrow, 7) = V5
Worksheets(sheet_ref).Cells(Lrow, 8) = V6

Next i

' The next part schedules another run in an
' hour's time, but only if it's before 17:00

end_hr = Worksheets("Parameters").Cells(9, 2)
  end_hr = Val(end_hr)
  end_min = Worksheets("Parameters").Cells(9, 3)
  end_min = Val(end_min)
  
int_hr = Worksheets("Parameters").Cells(7, 2)
  int_hr = Val(int_hr)
  int_min = Worksheets("Parameters").Cells(7, 3)
  int_min = Val(int_min)
  
  If Now() < Date + TimeSerial(end_hr, end_min, 0) Then
    NextRun = Now() + TimeSerial(int_hr, int_min, 0)
    Application.OnTime NextRun, "MyMacro"
  End If
  Workbooks(othfil).Activate
  Application.ScreenUpdating = True
End Sub
 

Forum statistics

Threads
1,085,163
Messages
5,382,075
Members
401,768
Latest member
katana_flyer

Some videos you may like

This Week's Hot Topics

Top