Edit this "Looping" code to start and stop at specific times?

B

Bret1

Board Regular
Joined
Jun 14, 2013
Messages
199
I'm using this simple "Looping" code to make my Macro continuously loop every 5 minutes. Is there a way to edit this to make the macro 1st run at 8:15am, then every 5 min, then stop looping at 3:15pm?
I may open the worksheet and run the Macro before 8:30, but I don't want the Macro to execute until 8:15. I also want the Macro looping to execute immediately if I run the Macro after 8:15am, but before 3:15pm.
Thanks
Code: 
Dim RunTimer As Date

Sub New_Copy_Over_Both_Columns()

RunTimer = Now + TimeValue("00:05:00")
Application.OnTime RunTimer, "New_Copy_Over_Both_Columns"
 
Sort by date Sort by votes
Bret1 said:
Thank you for your help. I'm very much a beginner, but I can't seem to get this to work. It is currently 6:05pm and I only changed the "initialRunTimer" to (18, 06, 0) and "runtimer to (18, 08, 0). I also need the ability to change the loop time from every 5 minutes to seconds (in the macro for testing purposes only). I don't see where this code designates to loop every 5 minutes.
Click to expand...
via this line(edit it to suit your needs. its currently set for testing purposes) :
VBA Code: 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 3
 
Upvote 0

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
MoshiM said:
via this line(edit it to suit your needs. its currently set for testing purposes) :
VBA Code: 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 3
Click to expand...
I copied over your code exactly as below and only added the simple "insert, copy, paste" command at the bottom, and adjusted the start and stop times for testing, but I can't figure out what I'm doing wrong. Current time when I ran it was 7:04pm..... It just hangs up and I had to force stop it....
Here is what I had...
Code: 
Dim RunTimer As Date
Sub New_Copy_Over_Both_Columns()
'RunTimer = Now + TimeValue("00:05:00")
    Dim finalTime As Date, currentTime As Date, intialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 3
 
    intialRunTimer = Date + TimeSerial(19, 5, 0)
   RunTimer = initialTimer
    finalTime = Date + TimeSerial(19, 6, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
    
        If RunTimer >= currentTime Then
     
            Debug.Print RunTimer
         
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            'Debug.Print RunTimer
            Exit Do
      
        End If
  
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
    
    Loop
 
    If currentTime < intialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

    'Shift (M:M) to right, copy (J1) and paste to (M1)
       Columns("M:M").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J1").Select
    Selection.Copy
    Range("M1").Select
    ActiveSheet.Paste

 End Sub
 
Upvote 0
Bret1 said:
I copied over your code exactly as below and only added the simple "insert, copy, paste" command at the bottom, and adjusted the start and stop times for testing, but I can't figure out what I'm doing wrong. Current time when I ran it was 7:04pm..... It just hangs up and I had to force stop it....
Here is what I had...
Code: 
Dim RunTimer As Date
Sub New_Copy_Over_Both_Columns()
'RunTimer = Now + TimeValue("00:05:00")
    Dim finalTime As Date, currentTime As Date, intialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 3
 
    intialRunTimer = Date + TimeSerial(19, 5, 0)
   RunTimer = initialTimer
    finalTime = Date + TimeSerial(19, 6, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
   
        If RunTimer >= currentTime Then
    
            Debug.Print RunTimer
        
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            'Debug.Print RunTimer
            Exit Do
     
        End If
 
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
   
    Loop
 
    If currentTime < intialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

    'Shift (M:M) to right, copy (J1) and paste to (M1)
       Columns("M:M").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J1").Select
    Selection.Copy
    Range("M1").Select
    ActiveSheet.Paste

 End Sub
Click to expand...

VBA Code: 
Dim RunTimer As Date

Sub New_Copy_Over_Both_Columns()
'RunTimer = Now + TimeValue("00:05:00")
    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 3
 
    initialRunTimer = Date + TimeSerial(19, 5, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(19, 6, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
    
        If RunTimer >= currentTime Then
     
            Debug.Print RunTimer
         
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            'Debug.Print RunTimer
            Exit Do
      
        End If
  
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
    
    Loop
 
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

    'Shift (M:M) to right, copy (J1) and paste to (M1)
    
    Columns("M:M").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("J1").Copy Range("M1")

 End Sub
 
Upvote 0
@MoshiM
Thank you very much for all your help on this! It is working now, except that every time it triggers, it triggers twice, than pauses for next trigger, then triggers twice, etc.
Below is my actual code. Can you adjust it so it will only trigger once each loop? Also, one last thing. I have message box pop up on starting the Macro to confirm running. On approving, can it pop up new small message box stating "Macro is Running"? Thanks so much!
Code: 
 Dim RunTimer As Date

Dim BoxOnce As Boolean      'At the beginning of all your code

Sub New_Copy_Over_Both_Columns()
  Dim RunTimer As Double
  If BoxOnce = False Then
    If MsgBox("WARNING: Auto-Save is Activated and may Save over today's data! Do you want to continue?", 36, "Confirm") = vbNo Then Exit Sub
    BoxOnce = True
  End If
  
  
    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 1, secondInterval As Integer = 0
 
    initialRunTimer = Date + TimeSerial(20, 25, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(20, 30, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
    
        If RunTimer >= currentTime Then
     
            Debug.Print RunTimer
         
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            'Debug.Print RunTimer
            Exit Do
      
        End If
  
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
    
    Loop
 
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If


   Application.ScreenUpdating = False
    
    'Select X:X and shift to right
    Columns("X:X").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    'Select R:R and copy to X1
    Columns("R:R").Select
    Selection.Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Font.Bold = False
  
       
    'Format Rows (1:1) as Time and (2:2) as Date
    Rows("1:1").Select
    Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Selection.Font.Bold = True
    Rows("2:2").Select
    Selection.NumberFormat = "m/d/yy"
    Selection.Font.Bold = True

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
    
    'Back Up Save at the end of every loop
        Application.ScreenUpdating = False
Application.DisplayAlerts = False
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1" & " "
            '.Close
        End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Bret1 said:
@MoshiM
Thank you very much for all your help on this! It is working now, except that every time it triggers, it triggers twice, than pauses for next trigger, then triggers twice, etc.
Below is my actual code. Can you adjust it so it will only trigger once each loop? Also, one last thing. I have message box pop up on starting the Macro to confirm running. On approving, can it pop up new small message box stating "Macro is Running"? Thanks so much!
Code: 
 Dim RunTimer As Date

Dim BoxOnce As Boolean      'At the beginning of all your code

Sub New_Copy_Over_Both_Columns()
  Dim RunTimer As Double
  If BoxOnce = False Then
    If MsgBox("WARNING: Auto-Save is Activated and may Save over today's data! Do you want to continue?", 36, "Confirm") = vbNo Then Exit Sub
    BoxOnce = True
  End If
 
 
    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 1, secondInterval As Integer = 0
 
    initialRunTimer = Date + TimeSerial(20, 25, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(20, 30, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
  
        If RunTimer >= currentTime Then
   
            Debug.Print RunTimer
       
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            'Debug.Print RunTimer
            Exit Do
    
        End If
 
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
  
    Loop
 
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If


   Application.ScreenUpdating = False
  
    'Select X:X and shift to right
    Columns("X:X").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  
    'Select R:R and copy to X1
    Columns("R:R").Select
    Selection.Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Font.Bold = False
 
     
    'Format Rows (1:1) as Time and (2:2) as Date
    Rows("1:1").Select
    Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Selection.Font.Bold = True
    Rows("2:2").Select
    Selection.NumberFormat = "m/d/yy"
    Selection.Font.Bold = True

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
  
    'Back Up Save at the end of every loop
        Application.ScreenUpdating = False
Application.DisplayAlerts = False
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1" & " "
            '.Close
        End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
  
End Sub
Click to expand...
Either you've scheduled the sub to be executed at the same time by accident for debugging purposes or some other code is blocking the execution until say minute 3 of your 5 minute interval at which point it will schedule again for whatever time is at the end of that 5 minute interval. Perhaps a long running task or an unclosed msgbox. The ontime event if not fed a latest time parameter will wait until a thread is available to execute.

Would you prefer if for example that if the script is ran off schedule at 1:18 PM instead of 1:15 then instead of scheduling for 1:20 PM, schedule it for 1:23PM?

The attached code doesn't implement this but I have made the adjustments that you asked for.

VBA Code: 
Sub New_Copy_Over_Both_Columns()

  Dim RunTimer As Date

    If BoxOnce = False Then
        If MsgBox("WARNING: Auto-Save is Activated and may Save over today's data! Do you want to continue?", 36, "Confirm") = vbNo Then
            Exit Sub
        Else
            MsgBox "Macro is running."
        End If
        BoxOnce = True
    End If
 
    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 10

    initialRunTimer = Date + TimeSerial(20, 24, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(20, 30, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
        If RunTimer >= currentTime Then
    
            Debug.Print RunTimer
        
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", latestTime:=RunTimer , Schedule:=True
            'Debug.Print RunTimer
            Exit Do
     
        End If
 
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
   
    Loop
 
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

   Application.ScreenUpdating = False
   
    'Select X:X and shift to right

    Columns("X:X").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
    'Select R:R and copy to X1
    Columns("R:R").Copy

    With Range("X1")
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        .Font.Bold = False
    End With
      
    'Format Rows (1:1) as Time and (2:2) as Date
    With Rows("1:1")
        .NumberFormat = "[$-F400]h:mm:ss AM/PM"
        .Font.Bold = True
    End With

    With Rows("2:2")
        .NumberFormat = "m/d/yy"
        .Font.Bold = True
    End With

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
   
    'Back Up Save at the end of every loop
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
       
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1" & " "
            '.Close
        End With
       
        With Application
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With

End Sub
 
Upvote 0
MoshiM said:
Either you've scheduled the sub to be executed at the same time by accident for debugging purposes or some other code is blocking the execution until say minute 3 of your 5 minute interval at which point it will schedule again for whatever time is at the end of that 5 minute interval. Perhaps a long running task or an unclosed msgbox. The ontime event if not fed a latest time parameter will wait until a thread is available to execute.

Would you prefer if for example that if the script is ran off schedule at 1:18 PM instead of 1:15 then instead of scheduling for 1:20 PM, schedule it for 1:23PM?

The attached code doesn't implement this but I have made the adjustments that you asked for.

VBA Code: 
Sub New_Copy_Over_Both_Columns()

  Dim RunTimer As Date

    If BoxOnce = False Then
        If MsgBox("WARNING: Auto-Save is Activated and may Save over today's data! Do you want to continue?", 36, "Confirm") = vbNo Then
            Exit Sub
        Else
            MsgBox "Macro is running."
        End If
        BoxOnce = True
    End If
 
    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 10

    initialRunTimer = Date + TimeSerial(20, 24, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(20, 30, 0)
    currentTime = Now
 
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
        If RunTimer >= currentTime Then
   
            Debug.Print RunTimer
       
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", latestTime:=RunTimer , Schedule:=True
            'Debug.Print RunTimer
            Exit Do
    
        End If
 
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval) ' <<<<<<<======New DateTime to check calculated here
  
    Loop
 
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

   Application.ScreenUpdating = False
  
    'Select X:X and shift to right

    Columns("X:X").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  
    'Select R:R and copy to X1
    Columns("R:R").Copy

    With Range("X1")
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        .Font.Bold = False
    End With
     
    'Format Rows (1:1) as Time and (2:2) as Date
    With Rows("1:1")
        .NumberFormat = "[$-F400]h:mm:ss AM/PM"
        .Font.Bold = True
    End With

    With Rows("2:2")
        .NumberFormat = "m/d/yy"
        .Font.Bold = True
    End With

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
  
    'Back Up Save at the end of every loop
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
      
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1" & " "
            '.Close
        End With
      
        With Application
            .DisplayAlerts = True
            .ScreenUpdating = True
        End With

End Sub
Click to expand...
I've tried several different start/stop times and different seconds and minutes pauses before looping. It works every time as it should with the start/stop times I set, and correct pause times, but every time it updates, it updates twice, then pauses for the correct set time, then updates twice again, etc. I don't have anything else running, and I only ran the Macro once for each test (so no double-running). I can't think of anything external that would be causing this. Before I added the start/stop times to the Macro it was not running twice each loop, so I can't help but to think it's something there. Before, I was just using the code below to make it start immediately and run until manually stopped. The auto start/stop times will be very helpful though. I eliminated the "Macro is Running" message box after all. It was not necessary as I thought.
Code: 
 RunTimer = Now + TimeValue("00:05:00")
  Application.OnTime RunTimer, "New_Copy_Over_Both_Columns"
 
Upvote 0
Bret1 said:
I've tried several different start/stop times and different seconds and minutes pauses before looping. It works every time as it should with the start/stop times I set, and correct pause times, but every time it updates, it updates twice, then pauses for the correct set time, then updates twice again, etc. I don't have anything else running, and I only ran the Macro once for each test (so no double-running). I can't think of anything external that would be causing this. Before I added the start/stop times to the Macro it was not running twice each loop, so I can't help but to think it's something there. Before, I was just using the code below to make it start immediately and run until manually stopped. The auto start/stop times will be very helpful though. I eliminated the "Macro is Running" message box after all. It was not necessary as I thought.
Code: 
 RunTimer = Now + TimeValue("00:05:00")
  Application.OnTime RunTimer, "New_Copy_Over_Both_Columns"
Click to expand...
Do you have anything in your before or after save events that would call this sub.
I've removed everything extra in this one. It should run every 10 seconds. Verify in the Immediate Window terminal.
VBA Code: 
Sub New_Copy_Over_Both_Columns()

    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date, RunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 10
    
    initialRunTimer = Date + TimeSerial(5, 31, 0)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(5, 50, 0)
    
    currentTime = Now
    
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
        If RunTimer >= currentTime Then
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            Exit Do
        End If
        
        'New DateTime to check calculated here
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval)
   
    Loop
    
    Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
    
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If

End Sub
 
Upvote 0
I just copied the code above into a new worksheet and added to it a simple process to insert row at (P:P), copy (L:L), and paste to (P:P).... starting with an "X" in (L:1) and (P:1). It started the process at the set time, and correct intervals (at 10 seconds), but each cycle, it ran multiple times before pausing. Maybe you can try the code to see if you get the same results? Thanks again for all your time and patience on this....
Code: 
Sub New_Copy_Over_Both_Columns()

    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date, RunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 10
    
    initialRunTimer = Date + TimeSerial(7, 28, 5)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(7, 30, 5)
    
    currentTime = Now
    
    Do Until DateDiff("s", RunTimer, finalTime) = 0 Or RunTimer > finalTime
        'Directly comparing was allowing an extra loop so datediff in seconds is used
        If RunTimer >= currentTime Then
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
            Exit Do
        End If
        
        'New DateTime to check calculated here
        RunTimer = RunTimer + TimeSerial(hourInterval, minuteInterval, secondInterval)
   
    Loop
    
    Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
    
    If currentTime < initialRunTimer Or currentTime >= finalTime Then
        Exit Sub
    End If
    
    
      Columns("P:P").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Select
    Selection.Copy
    Columns("P:P").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
End Sub
 
Upvote 0
Bret1 said:
@MoshiM ..... I forgot to tag you in my above response and just wanted to make sure you were notified. Sorry.
Click to expand...
I got 2 loops from the scenario 2 mentioned in post #15. I would reccomend writing the value of runTimer to a cell and then retrieving it when needed for unscheduling as its value will be erased if any of your code encounters an unhandled error.

VBA Code: 
Public RunTimer As Date

Sub New_Copy_Over_Both_Columns()

    Dim finalTime As Date, currentTime As Date, initialRunTimer As Date, RunTimer As Date
 
    Const hourInterval As Integer = 0, minuteInterval As Integer = 0, secondInterval As Integer = 10
        
    On Error Resume Next
        Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=False
    On Error GoTo 0
        
    initialRunTimer = Date + TimeSerial(7, 8, 5)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(7, 11, 5)
    
    currentTime = Now
    
    If currentTime < initialRunTimer Then
        Application.OnTime initialRunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        Exit Sub
    ElseIf currentTime >= initialRunTimer And currentTime < finalTime Then
        
        RunTimer = currentTime + TimeSerial(hourInterval, minuteInterval, secondInterval)
        
        If DateDiff("s", finalTime, RunTimer) = 0 Or RunTimer > finalTime Then
            Exit Sub
        Else
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        End If
        
    Else
        Exit Sub
    End If
    
    Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
    
    
    Columns("P:P").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Copy Columns("P:P")

    Application.CutCopyMode = False
    
End Sub

If you set up the interval addition correctly it will no longer run precisely every 5 minutes from 8:15 to 3:15 but will instead run 5 minutes after whenever it was last ran up until finalTime
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
Question Box only once in a looping Macro?
Replies
2
Views
340
Bret1
B
J
  • Question
VBA code to send an email if a certain IF Criteria is met that loops when the spreadsheet is open
Replies
1
Views
292
joeyc123
J
B
  • Question
Automatically run this VBA macro everyday at a given time
Replies
2
Views
1K
Logit
Logit
P
  • Solved
Never ending loop with OnTime
Replies
4
Views
261
picklefactory
P
L
  • Solved
VBA Run-time Errors
Replies
3
Views
555
StephenCrump
S

Forum statistics

Threads
1,215,906
Messages
6,127,664
Members
449,397
Latest member
Bastbog

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top