I currently have a macro that reaches out to a directory and pulls some data into my spreadsheet. Originally I just had a button to bring the information in and a button to erase everything but needs have changed and I now need it to automatically run the macro to clear the existing data and then pull new data every hour or so.
Looking through the different ways I could potentially pause the macro is appears that a loop is the best way to go for me because it will allow me to still interact with the spreadsheet while the wait is running.
All that said, here is what I currently have which seems to simply loop through everything without ever pausing at all.
At the end of my macro I use the following
Call DelayOneHour
Call RepActiveTicketsDelete
Call DelayTwoSeconds
Call RepActiveTicketsDataGrab
And here are the loops
Sub DelayOneHour()
Dim NowTick As Long
Dim EndTick As Long
NowTick = Now
EndTick = Now + TimeValue("0:01:00")
Do Until NowTick >= EndTick
DoEvents
NowTick = Now()
Loop
End Sub
Sub DelayTwoSeconds()
Dim NowTick As Long
Dim EndTick As Long
NowTick = Now
EndTick = Now + TimeValue("0:01:00")
Do Until NowTick >= EndTick
DoEvents
NowTick = Now()
Loop
End Sub
Thanks for looking!
I'd consider Application.OnTime as a way to effectively schedule a procedure to run at a later time. This frees up the runtime environment (i.e., so you could run other macros from other workbooks during the intervening 1 hour, etc).
Instead of:
Call DelayOneHour
Call RepActiveTicketsDelete
Call DelayTwoSeconds
Call RepActiveTicketsDataGrab
Do this:
'Run the specified procedure in one hour:
Application.OnTime Now + TimeValue("00:60:00"), "RepActiveTicketsDelete"
Exit Sub
Then, at the end of the RepActiveTicketsDelete procedure, you scheduled the RepActiveTicketsDataGrab procedure:
'Run the specified procedure in two seconds:
Application.OnTime Now + TimeValue("00:00:02"), "RepActiveTicketsDataGrab"
Exit Sub
Related
I am writing a piece of VBA code to display a countdown timer. Excel Sheet 1 lists times and descriptions of the events and sheet 2 displays the countdown.
The idea is once the first event has successfully counted down, it checks the date of the second event, and if it is today it proceeds to count down to the second event and so on. The countdown aspect works successfully for the first time and description, but when it finishes counting down to the first event it stops altogether.
There are 3 subs, the first works out if the event is today and how long it needs to count down for. The first calls the second which does the counting down by subtracting a TimeSerial(0,0,1) and the third is a timer. I will admit I borrowed the 2nd and 3rd from a nicely written piece I found online (credit to whoever wrote that, thanks).
I have simplified what I have written below:
For i=1 to 10
If *Conditions to determine if countdown should happen exist*
*calculate time to countdown and sets it to sheets("Countdown").Cells("A13")*
Cells(13, 1) = TotaltimeCountdown
Call Countdowntimer
End if
Next i
Sub Countdowntimer()
Sheets("Countdown").Activate
Dim Counter As Range
Set Counter = ActiveSheet.Range("A13")
If Counter.Value > 0 Then
Counter.Value = Counter.Value - TimeSerial(0, 0, 1)
Call Timer
ElseIf Counter.Value <= 0 Then
Sheets("Countdown").Range("A13:H17").ClearContents
Exit Sub
End If
End Sub
'Sub to trigger the reset of the countdown timer every second
Sub Timer()
Dim gCount As Date
gCount = Now + TimeValue("00:00:01")
Application.OnTime gCount, "Countdowntimer"
End Sub
I put a message box after calling Countdowntimer in the first sub and was able to establish that it displayed the amount of time to count down, then displayed the messagebox and cycled through each value of i. Only THEN did it actually proceed with the countdown.
Any suggestions on how to make the for loop pause completely until the countdown from the called sub is finished?
Any suggestions appreciated
The issue is using Application.OnTime and for a count down timer use a Do loop with DoEvents to count down.
Something like that:
Option Explicit
Public Sub CountDownTimer()
With ThisWorkbook.Worksheets("Countdown")
Dim Duration As Long
Duration = 10 ' needs to be in seconds!
'if your cell has a real datetime then use
Duration = .Range("A13").Value * 24 * 60 * 60
Dim TimerStart As Double
TimerStart = Timer()
Do While Timer <= TimerStart + Duration
.Range("A13").Value = TimeSerial(0, 0, TimerStart + Duration - Timer)
DoEvents
Loop
ThisWorkbook.Worksheets("Countdown").Range("A13:H17").ClearContents
End With
End Sub
This has been asked before but i have tried all the suggestions without success. I am running a VB for Excel subroutine that is controlled by user input read from the spreadsheet and that loops to recalculate values in memory within the subroutine. I have a line that outputs the iteration number to a cell for the user to see the progress and verify it is running properly. The cell updates for a few iterations (usual 4) and then ceases to show progress even though the routine will eventually proceed to completion at which time the cell finally updates. The current procedure may run 600-700 iterations to reach a converged solution.
The best way in my opinion to show the progress is to create UserForm. Below you'll find VBA code you should place in this UserForm. Just insert there 1 button and one caption - it should works. Try :)
In a module:
Sub UserFormTest()
UserForm1.Show
End Sub
In a UserForm:
Private Sub CommandButton1_Click()
Dim r As Integer
For r = 2 To 10000
'Your code goes here
Call Aktual(r)
Timeout 0.01
Next r
Application.ScreenUpdating = True
Unload Me
End Sub
Private Sub Aktual(intProgres As Integer)
Label1.Caption = "Progress " & intProgres
End Sub
Sub Timeout(seconds As Double)
Start_Time = Timer
Do
DoEvents
Loop Until (Timer + 1000 - Start_Time) >= seconds
End Sub
I currently have this Excel VBA code written using Bloomberg API. I am trying to pull data from Bloomberg into Excel using VBA. That is working fine but the problem is that I have another macro that then copies the data from Bloomberg and pastes it in another sheet.
If the data hasn't all been output from Bloomberg then I end up having insufficient data to copy then paste into the other sheet.
Currently, I am using this line of code:
Application.OnTime Now + TimeValue("00:01:45"), "RunAll"
which waits after running the first macro for 1 min 45s till it runs the remaining macros. It is useful but way too much time. Issue is that this is around how long the data takes to output.
Is there any other more efficient way for me to pull in the bloomberg data faster by ensuring that the data gets output into excel faster?
One way to handle it would be when you start your second macro that copies the data, check to see to see if a mid-point cell is empty (something like A100?? Seeing your code would help here...). If so, wait 10 seconds and check again. This will force that second macro to stay in a holding pattern while the first one catches up.
Word of caution though, I would set a max number of loops otherwise if that data doesn't download for some reason it won't hang up your machine.
UPDATE 1:
I wrote out the code below to accomplish what you're trying to do. There are a couple of things you'll need to work into your current code, but it I've purposely made it comment heavy so you should be able to follow. Let me know if this works for you.
Public boolBloombergCompleted As Boolean
Sub GetBloombergData()
'add this line after the data grab is complete
boolBloombergCompleted = True
End Sub
Sub WriteData()
Dim iRow As Integer
Dim boolTimeOut As Boolean
'change the last number as fit, make sure it's larger than the number of rows of data you're pulling in though
For iRow = 1 To 1000
' Check to see if the cell is blank
If Sheet1.Cells(iRow, 1) = vbNullString Then
' If the cell is blank and GetBloombergData has completed then exit sub
If boolBloombergCompleted = True Then
Exit Sub: Debug.Print "WriteData completed"
Else
' Call the wait function below
boolTimeOut = WaitForDataGrabToCatchUp(Sheet1.Cells(iRow, 1))
If boolTimeOut = True Then GoTo TimeOutErr:
End If
End If
' < Add your code to write data in here >
Next iRow
Exit Sub
TimeOutErr:
MsgBox "The write sub timed out while waiting for data to load", vbExclamation
End Sub
Function WaitForDataGrabToCatchUp(rng As Range) As Boolean
Dim StartTime1 As Long
Dim StartTime2 As Long
Dim PauseTime As Long
Dim StopTime As Long
' Set the amount of time to pause between checking the spreadsheet for updates
PauseTime = 5 'seconds
' Set the maximum amount of time to wait before timing out
StopTime = 60 'seconds
' StartTime1 is used for calculating overall time
StartTime1 = Timer
Do While rng = vbNullString
' check if the StopTime has been reached
If Timer - StartTime1 > StopTime Then
WaitForDataGrabToCatchUp = True
Exit Function
Else
' loop for amount of PausedTime (the DoEvents part here is key to keep the data grab moving)
StartTime2 = Timer
Do While Timer < StartTime2 + PauseTime
Debug.Print Timer - StartTime1
DoEvents
Loop
End If
Loop
WaitForDataGrabToCatchUp = False ' means it did not time out
End Function
I have a list of stock prices pulled from Google finance and placed in different sheets in my Excel. I'm wondering, Can I refresh Excel sheet every SECOND (not minute) according to the Google finance stock price?
This can be done without having a macro constantly running. It relies on the Application.OnTime method which allows an action to be scheduled out in the future. I have used this approach to force Excel to refresh data from external sources.
The code below is based nearly exclusively on the code at this link: http://www.cpearson.com/excel/ontime.aspx
The reference for Application.OnTime is at: https://msdn.microsoft.com/en-us/library/office/ff196165.aspx
Dim RunWhen As Date
Sub StartTimer()
Dim secondsBetween As Integer
secondsBetween = 1
RunWhen = Now + TimeSerial(0, 0, secondsBetween)
Application.OnTime EarliestTime:=RunWhen, Procedure:="CodeToRun", Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:="CodeToRun", Schedule:=False
End Sub
Sub EntryPoint()
'you can add other code here to determine when to start
StartTimer
End Sub
Sub CodeToRun()
'this is the "action" part
[A1] = WorksheetFunction.RandBetween(0, 100)
'be sure to call the start again if you want it to repeat
StartTimer
End Sub
In this code, the StartTimer and StopTimer calls are used to manage the Timers. The EntryPoint code gets things started and CodeToRun includes the actual code to run. Note that to make it repeat, you call StartTimer within CodeToRun. This allows it to loop. You can stop the loop by calling the StopTimer or simply not calling StartTimer again. This can be done with some logic in CodeToRun.
I am simply putting a random number in A1 so that you can see it update.
Sub RefreshFormulasEverySecond()
Dim dtTargetTime As Date
Debug.Print "Started"
Do While Range("A1").Value <> "STOP"
Application.Calculate
dtTargetTime = Now + TimeValue("0:00:01")
Do While Now < dtTargetTime
DoEvents
Loop
Debug.Print Now
Loop
Debug.Print "Stopped"
End Sub
You could have this macro running in the background. Paste it into a VBA module. You can run it from there or else put a button on the sheet and use that to trigger it. It's written to stop running when the word "STOP" is typed in cell A1 of whatever sheet the user is looking at.
I'm not sure it's the greatest idea to have a macro running continuously in the background, but that was the only way I could think of.
I'm using the Application.Ontime event to pull a time field from a cell, and schedule a subroutine to run at that time. My Application.Ontime event runs on the Workbook_BeforeSave event. As such, if a user (changes the desired time + saves the workbook) multiple times, multiple Application.Ontime events are created. Theoretically I could keep track of each event with a unique time variable.. but is there a way to check/parse/cancel pending events?
Private Sub Workbook_BeforeSave
SendTime = Sheets("Email").Range("B9")
Application.OnTime SendTime, "SendEmail"
End Sub
Private Sub Workbook_BeforeClose
Application.OnTime SendTime, "SendEmail", , False
End Sub
So if I:
change B9 to 12:01, Save the workbook
change B9 to 12:03, Save the workbook
change B9 to 12:05, Save the workbook
change B9 to 12:07, Save the workbook
etc
I end up with multiple events firing. I only want ONE event to fire (the most recently scheduled one)
How can I cancel ALL pending events (or enumerate them at least) on the Workbook_BeforeClose event?
I don't think you can iterate through all pending events or cancel them all in one shabang. I'd suggest setting a module level or global boolean indicating whether or not to fire your event. So you'd end up with something like this:
Dim m_AllowSendMailEvent As Boolean
Sub SendMail()
If Not m_AllowSendMailEvent Then Exit Sub
'fire event here
End Sub
Edit:
Add this to the TOP of the sheet module which contains the range which contains the date/time value you're after:
' Most recently scheduled OnTime event. (Module level variable.)
Dim PendingEventDate As Date
' Indicates whether an event has been set. (Module level variable.)
Dim EventSet As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim SendTimeRange As Range
' Change to your range.
Set SendTimeRange = Me.Range("B9")
' If the range that was changed is the same as that which holds
' your date/time field, schedule an OnTime event.
If Target = SendTimeRange Then
' If an event has previously been set AND that time has not yet been
' reached, cancel it. (OnTime will fail if the EarliestTime parameter has
' already elapsed.)
If EventSet And Now > PendingEventDate Then
' Cancel the event.
Application.OnTime PendingEventDate, "SendEmail", , False
End If
' Store the new scheduled OnTime event.
PendingEventDate = SendTimeRange.Value
' Set the new event.
Application.OnTime PendingEventDate, "SendEmail"
' Indicate that an event has been set.
EventSet = True
End If
End Sub
And this to a standard module:
Sub SendEmail()
'add your proc here
End Sub
Each time you call Application.Ontime save the time the event is set to run (you could save it on a sheet or in a module scoped dynamic array)
Each time your event fires, remove the corresponding saved time
To cancel all pending event iterate through the remaining saved times calling Application.Ontime with schedule = false
I think I may have a solution that works, based on some of the advice already given.
In short, we create a global array and each time the user hits save the SendTime is written to the array. This serves to keep track of all our scheduled times.
When the workbook is closed, we loop through the array and delete all scheduled times.
I tested this and it seemed to work on Excel 2003. Let me know how you get on.
Dim scheduleArray() As String //Set as global array to hold times
Private Sub Workbook_BeforeSave
SendTime = Sheets("Email").Range("B9")
AddToScheduleArray SendTime
Application.OnTime SendTime, "SendEmail"
End Sub
Private Sub Workbook_BeforeClose
On Error Resume Next
Dim iArr As Integer, startTime As String
For iArr = 0 To UBound(scheduleArray) - 1 //Loop through array and delete any existing scheduled actions
startTime = scheduleArray(iArr)
Application.OnTime TimeValue(startTime), "SendEmail", , False
Next iArr
End Sub
Sub AddToScheduleArray(startTime As String)
Dim arrLength As Integer
If Len(Join(scheduleArray)) < 1 Then
arrLength = 0
Else
arrLength = UBound(scheduleArray)
End If
ReDim Preserve scheduleArray(arrLength + 1) //Resize array
scheduleArray(arrLength) = startTime //Add start time
End Sub
or you can just create some cell (like abacus), for example:
if I use application.ontime:
if range("V1") < 1 then
Application.OnTime dTime, "MyMacro"
range("V1")=range("V1") + 1
end if
if I want to stop counting...
Application.OnTime dTime, "MyMacro", , False
range("V1")=range("V1") - 1