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