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 have cross posted here! But so far no luck!

Auto Start/Stop Macro at specific times - VBA Express Forum
Automatically Start/Stop Macro at Specific Weekday Times • ExcelKey.com
VBA Copy and Paste to Infinite Range?
Automatically Start/Stop Macro at Specific Weekday Times
http://www.mrexcel.com/forum/excel-...macro-specific-weekday-times.html#post3396828

 

[lancerj017]

Add this code below on ThisWorkbook

Private Sub Workbook_Open()
    Call StartTimer 'when opening your workbook it will start the timer
End Sub

then add this code to your module

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()
    Dim Crng As Range, Prng As Range
    Dim StartTime As String
    Dim StopTime As String
    Dim CurrentTime As String
    CurrentTime = Time
    StartTime = "6:30:00 AM"
    StopTime = "5:30:00 PM"
    If CurrentTime >= startime Then
        If CurrentTime >= StopTime Then
            Call StopTimer
        Else
            Range("C1") = Range("C1") + 1
            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 If
    Else
        If TimerEnabled Then StartTimer
    End If
End Sub
Sub StopTimer()
    On Error Resume Next
    TimerEnabled = False
    Application.OnTime EarliestTime:=Now(), Procedure:=cRunWhat, Schedule:=False
End Sub

give us feedback if its working or not

 

[chrisjwhite90]

Thank you so much for the help lancer!

It works perfectly, but what can I now add to only record data on weekdays (Monday-Friday)? I plan on changing the cRunIntervalSeconds to less than 5 seconds soon, and if the macro runs through Sat and Sun that will be a ton of data I would have to go back manually to delete. Doable, but still tedious. What can I add to the code to achieve this?

 

[lancerj017]

Change the CopyPaste code and put this code below.

Sub CopyPaste()
    Dim Crng As Range, Prng As Range
    Dim StartTime As String
    Dim StopTime As String
    Dim CurrentTime As String
    Dim CurrentDate As String
    CurrentDate = Date
    CurrentTime = Time
    StartTime = "6:30:00 AM"
    StopTime = "5:30:00 PM"
    If Not Weekday(CurrentDate) = vbSaturday Or Weekday(CurrentDate) = vbSunday Then
        If CurrentTime >= startime Then
            If CurrentTime >= StopTime Then
                Call StopTimer
            Else
                Range("C1") = Range("C1") + 1
                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 If
        Else
            If TimerEnabled Then StartTimer
        End If
    Else
        Call StopTimer
    End If
End Sub

 

[chrisjwhite90]

lancer,

ever since I made the changes to include the weekday logic, the code has stopped working. I even deleted that portion and put the old portion in, and it still doesn't work. It was working fine before. I've breaked the code, restarted my excel, a even changed the time intervals at the top and spell checked everything. Do you know why this could be? It was working fine before.

Please see the link to download my spreadsheet and try it for yourself.

d38abf98a8_e/AUTO RECORD DATA.xlsm : File Sharing - Upload and Send big Files : FileToLink

 

[lancerj017]

Hi Chris,

If you planning to leave your excel even in weekends and not to close your workbook, I decided to change to Stoptimer Code. please run some test for the new code if this will suit to your needs.

New Code

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
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()
    Dim Crng As Range, Prng As Range
    Dim StartTime As String
    Dim StopTime As String
    Dim CurrentTime As String
    Dim CurrentDate As String
    CurrentDate = Format(Date, "mm/dd/yy")
    CurrentTime = Format(Time, "h:mm:ss AM/PM")
    StartTime = "6:30:00 AM"
    StopTime = "5:30:00 PM"
    If Weekday(CurrentDate) = 7 Or Weekday(CurrentDate) = 1 Then
        Call StopTimer
    Else
        If CurrentTime >= StartTime Then
            If CurrentTime >= StopTime Then
                Call StopTimer
            Else
                Range("C1") = Range("C1") + 1
                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
                Call StartTimer
            End If
        Else
            Call StartTimer
        End If
    End If
End Sub
Sub StopTimer()
    On Error Resume Next
    TimerEnabled = False
    RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True
End Sub

 

[chrisjwhite90]

It worked at first, but then I started having issues with getting it to start. I ran several tests, changing the start and stop times ahead of my current time to see when it would initiate. But again at 6:30am I had no luck. Could it be something with the change from am to pm in the code? Or possibly a glitch when I close the workbook and open it back up? All the times I tested were from am to am or pm to pm, not going from one to the other. I'm not sure if this would cause issues.

 

[lancerj017]

did you check your time in your pc? it's working for me i don't know what's the problem but i try to figure it out.

here's the final code delete your previous code then add this.

The format of your time is still 06:30:00 AM not 6:30:00 AM? am i right?

it should be 6:30:00 AM and 5:30:00 PM try to run this code below don't edit anything i hope this code will successfully work to you..

Public RunWhen As Double
Public Const cRunIntervalSeconds = 2    ' 1 second, set 900 for 15 minute intervals
Public Const cRunWhat = "CopyPaste"     ' the name of the procedure to run
Sub Timer()
    On Error Resume Next
    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 StartTime As String
    Dim StopTime As String
    Dim CurrentTime As String
    Dim CurrentDate As String
    CurrentDate = Format(Date, "mm/dd/yy")
    CurrentTime = Format(Time, "h:mm:ss AM/PM")
    StartTime = "6:30:00 AM"
    StopTime = "5:30:00 PM"
    If Weekday(CurrentDate) = 7 Or Weekday(CurrentDate) = 1 Then
        Call Timer
    Else
        If CurrentTime >= StartTime Then
            If CurrentTime >= StopTime Then
                If Cells(1, 1).Interior.ColorIndex = xlNone Then
                    Cells(1, 1).Interior.ColorIndex = 3
                    Cells(1, 2).Interior.ColorIndex = xlNone
                Else
                    Cells(1, 1).Interior.ColorIndex = xlNone
                    Cells(1, 2).Interior.ColorIndex = 3
                End If
                Call Timer
            Else
                If Cells(1, 1).Interior.ColorIndex = xlNone Then
                    Cells(1, 1).Interior.ColorIndex = 3
                    Cells(1, 2).Interior.ColorIndex = xlNone
                Else
                    Cells(1, 1).Interior.ColorIndex = xlNone
                    Cells(1, 2).Interior.ColorIndex = 3
                End If
                Range("C1") = Range("C1") + 1
                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
                Call Timer
            End If
        Else
            If Cells(1, 1).Interior.ColorIndex = xlNone Then
                Cells(1, 1).Interior.ColorIndex = 3
                Cells(1, 2).Interior.ColorIndex = xlNone
            Else
                Cells(1, 1).Interior.ColorIndex = xlNone
                Cells(1, 2).Interior.ColorIndex = 3
            End If
            Call Timer
        End If
    End If
End Sub

 

[lancerj017]

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?