Automatically Start/Stop Macro at Specific Weekday Times

[chrisjwhite90]

Hello,

I have a completed macro that records price data of certain variables every 30 seconds, it pastes them to a range below, and continues to log these changes in prices by pasting the new variable below the previous.

The code works perfectly, however I need to make a change that I am not sure how to do.

Currently I have start and stop buttons to initiate the recording process, but I'd like to change this to automatically start the macro at a specific time, and end it at a specific time, every day from monday thru friday. I will always have the spreadsheet open, so basically I would like it to automatically start at 6:30 am every weekday, and stop at 5:30pm every weekday.

I'm a novice in VBA, and I've tried to edit my code with no luck. My current code includes the buttons (StartTimer assigned to the Start button, StopTimer for the Stop button), but I'd like to remove them somehow and just automate the process without them. I have this so far:

[FONT=Courier New]Public RunWhen As Double
Public Const cRunIntervalSeconds = 30    ' 1 second, set 900 for 15 minute intervals
Public Const cRunWhat = "CopyPaste"     ' the name of the procedure to run
Private TimerEnabled As Boolean         ' This value can only be changed by code in this module

Sub StartTimer()
    TimerEnabled = True
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
                       Schedule:=True
End Sub

Sub CopyPaste()
     Range("C1") = Range("C1") + 1
    Dim Crng As Range, Prng As Range
    Set Crng = Worksheets(1).Range("A4:Q4")
    Set Prng = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    Crng.Copy
    Prng.PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False

    If TimerEnabled Then StartTimer

End Sub

Sub StopTimer()
    On Error Resume Next
    TimerEnabled = False
    Application.OnTime EarliestTime:=Now(), Procedure:=cRunWhat, _
                       Schedule:=False

End Sub[/FONT]

I don't know exactly where and how to put in a specified start time, record values every increment that I have set, and then end at the specific time. Would I need to set a second timer? Would I need to specify an additional variable to do this? These are the questions I do not know. I would truly appreciate help on this.

(((I have cross posted, I will paste links below)))

 

[chrisjwhite90]

I just need something to stop the copying process at the time I have specified daily, and then start up the copying process at the time I have specified.

by the way i did not add the sub for Stoptimer? why do you need the StopTimer? to stop the time or to stop copying process?

 

[chrisjwhite90]

I have the new code in and am testing it now. Very interesting with the colored cell at the top, is that just to indicate that the macro is indeed running, by constantly switching left and right by the timer specified at the top? I like it, good add in.

I'll let you know how everything works out on my end here. Thanks for your continued assistance.

 

[lancerj017]

No problem just give me feedback if your problem is solve or not.

 

[chrisjwhite90]

So here's what I found. The macro automatically works from AM to AM, PM to PM, and PM to AM. BUT for some reason doesn't work from AM to PM. I don't know why.

I thought of a way around this, military time. What is a quick fix so I wont have to make the distinction between AM/PM, and rather just based off the 24 hr time itself.

 

[lancerj017]

Hi Chris,

This is the final code that i made..

Add This Code to ThisWorkbook Module

Private Sub Workbook_Open()
    Timer 'when opening your workbook it will start the timer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    StopTimer 'to stop the macro from running
End Sub

Add This Code to your Module ignore the old code that i gave it to you

Public RunWhen As Double
Public Const cRunIntervalSeconds = 1    ' 1 second, set 900 for 15 minute intervals
Public Const cRunWhat = "CopyPaste"     ' the name of the procedure to run
Sub Timer()
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True
End Sub
Sub CopyPaste()
    Dim Crng As Range, Prng As Range
    Dim CurrentTime As Date
    Dim CurrentDate As Date
    Dim WS As Worksheet
    Set WS = Worksheets("Sheet1") [B][COLOR=#008000]'change to suit[/COLOR][/B]
    CurrentDate = Format(Now(), "mm/dd/yy")
    CurrentTime = Format(Now(), "h:mm:ss AM/PM")
    If Weekday(CurrentDate) = 7 Or Weekday(CurrentDate) = 1 Then
        Call Timer
    Else
        If CurrentTime >= TimeValue("8:30:00 AM") Then [COLOR=#008000][B]'Change TimeValue depend on your time to Start the macro[/B][/COLOR]
            If CurrentTime <= TimeValue("6:33:00 PM") Then [COLOR=#008000][B]'Change TimeValue depend on your time to Stop the macro[/B][/COLOR]
                If WS.Cells(1, 1).Interior.ColorIndex = xlNone Then
                    WS.Cells(1, 1).Interior.ColorIndex = 3
                    WS.Cells(1, 2).Interior.ColorIndex = xlNone
                Else
                    WS.Cells(1, 1).Interior.ColorIndex = xlNone
                    WS.Cells(1, 2).Interior.ColorIndex = 3
                End If
                WS.Range("C1") = WS.Range("C1") + 1
                Set Crng = WS.Range("A4:Q4")
                Set Prng = WS.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                Crng.Copy
                Prng.PasteSpecial (xlPasteValues)
                Application.CutCopyMode = False
            Else
                If WS.Cells(1, 1).Interior.ColorIndex = xlNone Then
                    WS.Cells(1, 1).Interior.ColorIndex = 3
                    WS.Cells(1, 2).Interior.ColorIndex = xlNone
                Else
                    WS.Cells(1, 1).Interior.ColorIndex = xlNone
                    WS.Cells(1, 2).Interior.ColorIndex = 3
                End If
            End If
        Else
            If WS.Cells(1, 1).Interior.ColorIndex = xlNone Then
                WS.Cells(1, 1).Interior.ColorIndex = 3
                WS.Cells(1, 2).Interior.ColorIndex = xlNone
            Else
                WS.Cells(1, 1).Interior.ColorIndex = xlNone
                WS.Cells(1, 2).Interior.ColorIndex = 3
            End If
        End If
    End If
    Call Timer
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=False
End Sub

 

[chrisjwhite90]

Oh man it was working perfectly all week! I sign on Sunday night (tonight), and I get "Run time error 1004: Method 'OnTime' of object' _Appllication' failed. Which is fine because I could just close it down and restart the excel to initiate it again. I just have to make sure to save when I leave every Friday. Unless you know of a way around this.

 

[lancerj017]

Click the debug mode and post it here the code that high lighted.

 

[chrisjwhite90]

It was the second line of the Sub Timer:

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True

But like I said, everything has run perfectly besides that little mishap. I'm incredibly pleased. Thanks for all the help!

 

[nitinsalunke]

It was the second line of the Sub Timer:

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True

But like I said, everything has run perfectly besides that little mishap. I'm incredibly pleased. Thanks for all the help!

I have a similar query. I have a code to copy data at intervals. I would like to automatically start at 9:18 am at 3 min intervals till 3.30pm
At 3.30pm the macro should automatically get stopped. I also want to ensure that it should not run on Saturday and sunday even if the file is opened on these days

below is my code:

Sub RecordData()
'
' RecordData Macro
'

'
Workbooks("Option_Chain_Analysis.xlsm").Activate
Sheets("NF OI").Select
Range("A11:X30").Select
Selection.Copy
Sheets("DataRecord").Select
Range("B2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
Sheets("NF OI").Select
Range("B2").Select

End Sub