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
Related
I am currently working on a program in VBA which opens a workbook from a server and gets information from some cells.
Because the location of the information will always be different I am using many parameters.
The problem I have is that the program moves faster than it can open the second workbook and the variable for it doesn't contain anything or the right address, it may get the address of the current workbook.
I tried to use Application.Wait Now + TimeSerial(0, 0, 15) but with no luck. It feels like the wait also stops from opening the second workbook because I get the out of range error and after it opens the second workbook.
While running the program with F8 it works just fine. I let it until the new workbook opens and then run the next line where I set the address of the new workbook.
With local files it works fine no wait needed
Trying to be more clear: when running the code with F8, the workbook from the hyperlink opens in about 5-8 seconds but when I run it with F5 the
wkb.FollowHyperlink command seems to fail, returning an error in the next steps since the wkb_activ = ActiveWorkbook will be the same workbook as the one that I started the macro(the one that is supposed to receive information). Even though I put a wait time of over a minute the hyperlink will not open the workbook. When I close the error message, the files opens.
I am open to any suggestions.
Thanks
Here is the code for the workbook opening, the variable col_index is a number and sheet_index is the variable for the sheet in the first workbook which gets the information.
For i = 2 To lastrow
If IsEmpty(sheet_index.Cells(i, col_index).Value) Then
End
Else
wkb.FollowHyperlink Address:=sheet_index.Cells(i, col_index).Value, NewWindow:=True
Application.Wait Now + TimeSerial(0, 0, 15)
Set wkb_activ = ActiveWorkbook
End If
I have found a solution. We created a new Sub with a loop in which it does nothing until the timer is greater than the value we chose. Here is the code:
Sub time(total)
starting_time = Timer
Do
DoEvents
Loop Until (Timer - starting_time) >= total
End Sub
And in the main Sub we have added the time(30) for a 30 second timer.
wkb.FollowHyperlink Address:=sheet_index.Cells(i, col_index).Value NewWindow:=True
time (30)
Set wkb_activ = ActiveWorkbook
I have built on Catalin's solution, this code will continue to check to see if a workbook has been opened until a timeout is reached
Public Function AwaitWorkbookOpenedByHyperlink(FilepathHyperlink As String, Optional TimeoutInSeconds As Integer = 5) As Workbook
Dim StartingWbkCount As Integer, CurrentWbkCount As Integer
StartingWbkCount = Workbooks.Count
CurrentWbkCount = Workbooks.Count
Dim StartTime As Long
StartTime = Timer
Dim ElapsedTime As Long
ElapsedTime = 0
ThisWorkbook.FollowHyperlink Address:=FilepathHyperlink
Do
Dim SplitTime As Long
SplitTime = Timer
Do
DoEvents
Loop Until (Timer - SplitTime) >= 0.2
CurrentWbkCount = Workbooks.Count
If StartingWbkCount <> CurrentWbkCount Then
Set AwaitWorkbookOpenedByHyperlink = Workbooks(Workbooks.Count)
Exit Function
End If
ElapsedTime = Timer - StartTime
Loop Until ElapsedTime > TimeoutInSeconds
Set AwaitWorkbookOpenedByHyperlink = Nothing
End Function
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
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
Hi I am using the following code to parsing some data from website to excel , I need to create a routine in order to update /Refresh the data and keep is up to date and I been advice to start new topic , is big list with multiple sheets so take long time every time excel has to calculate , I hope someone can may help me out
Public Function giveMeValue(ByVal link As Variant) As Variant
Set htm = CreateObject("htmlFile")
With CreateObject("msxml2.xmlhttp")
.Open "GET", link, False
.send
htm.body.innerhtml = .responsetext
End With
If Not htm.getelementbyId("JS_topStoreCount") Is Nothing Then
giveMeValue = htm.getelementbyId("JS_topStoreCount").innerText
Else
giveMeValue = "0"
End If
htm.Close
Set htm = Nothing
End Function
to retrive the value I use =GiveMeValue(A1) and condition formatting the returned value I use the Following code :
Dim color As Integer 'Start Color range
For Each cell In Sheets(1).Range("M4:M5000")
If IsEmpty(cell) Then GoTo nextcell:
If Not IsNumeric(cell.Value) Then GoTo nextcell:
If cell.Value > 14 Then
color = 4
ElseIf cell.Value < 8 Then color = 3
Else: color = 6
End If
cell.Interior.ColorIndex = color
nextcell:
Next cell
End Sub
so as I am not skilled at all with VBA I may unappropriate use the following code to try get refresh it but without result:
Sub Refresh()
Dim WAIT As Double
WAIT = Timer
While Timer < WAIT + 10
DoEvents 'do nothing'
ActiveWorkbook.RefreshAll
Wend
MsgBox "Update Finished Successfully !"
'End Sub
Sounds ambitious. I like it! :)
For a start can you just use conditional formatting? Will be a lot quicker than looping through every cell and changing colour.
Secondly, make your GiveMeValue function "volatile" (http://www.excel-easy.com/vba/examples/volatile-functions.html) so that it refreshes every time you recalculate the page i.e. add a line "application.volatile(true) before anything else in the function.
Thirdly: run your refresh code in the "worksheet_calculate" event and change it to:
Sub Refresh()
Dim WAIT As Double
WAIT = Timer
While Timer < WAIT + 10
DoEvents 'do nothing'
Wend
wsSheet.Calculate
End Sub
So it runs... waits a bit... calculates, then that calculation triggers another wait... etc... Now that your function is volatile, it should refresh all the "getvalue" formulas you have on the current sheet...
And I guess forthly put a "wsSheet.calculate" in the worksheet_activate event to trigger start of that endless loop...
Having said all that, perhaps that endless loop will cause huge issues i.e. mega computer slow down, inability to use computer, and general doom... only one way to find out! The doevents thing should in theory make everything OK. Maybe add if activesheet.codename = "wsSheet" then... so its only running when you're on that sheet...
Hopefully this is an easy one. I have a series of charts in MS Excel that point to data on the same worksheet. The data on the worksheet is calculated using a VBA function. When the data is updated by the VBA function the new numbers are not reflected in the charts that are pointing to them. I tried calling Application.Calculate, but that didn't do the trick. Any thoughts?
UDPATE:
I was able to duplicate this issue on a much smaller scale. Here's how:
Create a new workbook
Rename Sheet 1 to "Summary"
Rename Sheet 2 to "Data"
Open the Summary sheet in the VBA editor and paste the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Parent.Range("worksheetDate") = Target Then
Application.CalculateFull
End If
End Sub
Create a new VBA module
Paste the following code into the new VBA module (I apologize - I can't get Stack Overflow to format this correctly for the life of me - this is the best I could get it to do):
.
Function getWeekValue (weekNumber As Integer, valuesRange As Range) As Integer
Dim aCell As Range
Dim currentDate As Date
Dim arrayIndex As Integer
Dim weekValues(1 To 6) As Integer
currentDate = ThisWorkbook.Names("worksheetDate").RefersToRange.Value
arrayIndex = 1
For Each aCell In valuesRange
If month(currentDate) = month(ThisWorkbook.Sheets("Data").Cells( _
aCell.Row - 1, aCell.Column)) Then
weekValues(arrayIndex) = aCell.Value
arrayIndex = arrayIndex + 1
End If
Next
getWeekValue = weekValues(weekNumber)
End Function
.
Modify the Data worksheet to match the following image:
Select Cell B1 and name the range "worksheetDate"
Duplicate rows 1 through 3 in the following image:
In row 4, under the "Week X" headers, enter the following formula
.
= getWeekValue(1, Data!$A$2:$M$2)
incrementing the first argument to the getWeekValue function by one for each week (e.g., pass 1 for Week 1, 2 for Week 2, 3, for Week 3, etc.
Create a bar graph using cells A3 through E4 as the data
Change the date in cell B2 to a date between 10/1/2010 and 12/31/2010, choosing a month other than the month that is currently in the cell. For example, if the date is 12/11/2010, change it to something like 11/11/2010 or 10/11/2010. Note that both the data and chart update correctly.
Modify the date in cell B2 gain. Note that the data updates, but the chart does not.
Oddly, after a period of time (several minutes) has elapsed, the chart finally updates. I'm not sure if this is because I have been performing other activities that triggered the update or because Excel is triggering an update after several minutes.
Just figured out the solution to this issue as I was suffering from the same.
I've just added "DoEvents()" prior to printing or exporting and the chart got refreshed.
example
Sub a()
Dim w As Worksheet
Dim a
Set w = Worksheets(1)
For Each a In w.Range("a1:a5")
a.Value = a.Value + 1
Next
DoEvents
End Sub
at the end of my changes I close the workbook and reopen it. that seems the easiest and most reliable way to update everything for me.
For example:
Sub a()
Dim w As Worksheet
Dim a
Set w = Worksheets(1)
For Each a In w.Range("a1:a5")
a.Value = a.Value + 1
Next
w.ChartObjects(1).Chart.Refresh
End Sub
This solution worked for me. For the offending worksheet add:
Private Sub Worksheet_Activate()
Dim rngSelection As Range
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objSeriesCollection As SeriesCollection
Dim objSeries As Series
Dim strFormula As String
Set rngSelection = Selection
For Each objChartObject In Me.ChartObjects
Set objChart = objChartObject.Chart
Set objSeriesCollection = objChart.SeriesCollection
For Each objSeries In objSeriesCollection
strFormula = objSeries.Formula
objSeries.Delete
Set objSeries = objSeriesCollection.NewSeries
objSeries.Formula = strFormula
Next objSeries
Next objChartObject
rngSelection.Select
End Sub
It's possible that the issue is the argument list of getWeekValue, which includes only the week number and the data stream.
If you add a third argument, worksheetDate, then Excel's recalculation engine will be hit on the side of the head with the fact that getWeekValue uses the value held in worksheetDate. In your current implementation, this fact is held only in the VBA code, where it is probably invisible to the recalculation engine.
I write this so hedgingly because I am not privy to the inner workings of the recalculation engine. (Maybe someone who knows about this better than I can comment on my speculation) But I did do a test, in which getWeekValue does have that third argument, and the chart does recalculate properly. Nice added benefit of this approach: you can remove all that other VBA event management. -HTH
I've found that calling this Sub works...
Sub DoAllEvents()
DoEvents
DoEvents
End Sub
BUT
Microsoft cautions about being caught with the next DoEvents executing before the first DoEvents completes, which can happen depending on how often it's called without a delay between calls. Thus DoEvents appears to be acting as a type of non maskable interrupt, and nesting non maskable interrupts can cause the machine to freeze for multiple reasons without any recovery other than reboot.
(Note: If one is not calling the routine above, often and quickly, nesting may not
be an issue.)
Using the following Sub below, which I modified from their suggestion, prevents this from happening.
Sub DoAllEvents()
On Error GoTo ErrorCheck
Dim i
For i = 1 To 4000 ' Start loop. Can be higher, MS sample shows 150000
'I've found twice is enough, but only increased it to four or 4000.
If i Mod 1000 = 0 Then ' If loop has repeated 1000 times.
DoEvents ' Yield to operating system.
End If
Next i
Exit Sub
ErrorCheck:
Debug.Print "Error: "; Error, Err
Resume Next
End Sub
I appears that the number of DoEvents needed is based on the number of background tasks running on your machine, and updating the graph appears to be a background task for the application. I only needed two DoEvents because I call the routine frequently; however, I may end up upping it later if needed.
I also keep the Mod at 1000 so to not change the lag between each DoEvents as Microsoft suggests, preventing nesting. One possible reason you might want to increase the number from 2000 to a higher number is if you system does not update the graph. Increasing this number allows the machine to handle larger numbers of background events that DoEvents might encounter through multiple calls as they are probably on a stack, and the DoEvents event is only allowed to run a specific number of cycles before marking its place in the stack to allow unhandled events and returning, leaving them to be handled on the next call. Thus the need for multiple calls. Changing this to their example of 150000 doesn't appear to slow the machine too much, to play it safe you might want to make it 150000.
Note: the first example Sub with two DoEvents is probably safe depending on how often you call the Sub, however, if called too often, your machine might freeze up. Your call. ;-)
PS: DoEvents will become one of your best calls if you create a lot of nested loops and the program doesn't behave as expected. Fortunately, this is available in all apps that use VBA!
Running Excel 2019.
Added the following to the macro code:
ActiveSheet.ChartObjects(1).Chart.Refresh
DoEvents
The chart now updates during macro execution
UDF getWeekValue has to be marked as volatile.
Function getWeekValue (weekNumber As Integer, valuesRange As Range) As Integer
Application.Volatile '!!
Dim aCell As Range
Dim currentDate As Date
'...
Just an idea: in your Worksheet_Change Sub, insert as the first line:
Application.EnableEvents = False
in order to avoid self-firing events....
Of course set it back to True at the end of the Sub.