Looping Web Queries Faster and Easier in VBA without the interuptions
There are two major poblems with using VBA to perform web queries, that will cause Excel to bug out and show the 1004 or its equivalent Error message.
1) Excel actually reads from your internet explorer when performing queries. When your cache is full, usually by the 40th to 50th query, your macro will bug out.
2) Excel will move on to the next query when the last one is still refreshing in the background in the case of multiple web queries.
I suggest two methods to resolve these issues. Method A adds VBA code to clear your cache when an error occurs. Additional VBA code is also provided to disable background queries and wait for a while before continuing at each web query. Method B performs the same web query as an MSXML2.XMLHTTP object. However, Method B functions more like a web crawler and is much more flexible. It allows you to search for specific data to copy into Excel, and in my opinion, is faster and more efficient than Method A.
Method A
The code to clear your cache is:
Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
Note that I only tested this code on XP. Changing the number at the end of the line tells your machine to clear different items.
Clear temp files: 8
Clear history: 1
Clear cookies: 2
Clear form data: 16
Clear saved passwords: 32
Clear everything: 255
Clear add on settings: 4351
The following tells Excel not to perform queries in the background.
With ActiveSheet.QueryTables("ABC").Refresh backgroundquery:=False
If setting background queries to false does not work, you can manually ask Excel to wait for a while before continuing.
Application.Wait (Now() + TimeValue("0:00:05"))
The following code provides you with an example of pulling historical stock prices for multiple companies from a hypothetical website called goohoo.com via web queries. It requires that you input a starting date into a cell that has been named as "Start_Date". To name a cell, select the cell and click Formulas>>Define Name. It assumes that you want historical data up till yesterday and will also pop up an input box asking you to select the range of cells where your stock symbols are located, before continuing with the web queries. Comments are in bold.
'Declare variables
Dim symbolrange As Range
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim url1 As String
Dim url2 As String
Dim ie As InternetExplorer
Sub main1()
'create an inputbox for user to specify range
On Error GoTo Handler 'if you click cancel on the pop up, exit macro
Set symbolrange = Application.InputBox _
("Select Range Containing Stock Symbols", _
"Select Range", Selection.Address(0, 0), Type:=8)
On Error GoTo 0 'Disable the error handler that we turned on above
Call setdate 'A macro to create part of the URL
Call setupconnection 'A macro to set up connection
Call grabdata 'A macro to loop data connection
Handler:
End Sub
Sub setdate()
'This macro converts date into partial URL
startdate = Range("Start_Date").Value
enddate = Date - 1
'Check if Startdate is correct
If startdate >= enddate Then
MsgBox "Your start date is later than your end date"
End
End If
'Check if startdate is too early
If enddate - startdate > 5000 Then
yesno = MsgBox _
("Confirm that your source supports this date range", vbYesNo)
If yes = vbNo Then End
End If
'If above checks are ok continue below
startmonth = WorksheetFunction.Text(Month(startdate) - 1, "00")
startday = Day(startdate)
startyear = Year(startdate)
startdate1 = "&a=" & startmonth & "&b=" & startday & "&c=" _
& startyear
startmonth = WorksheetFunction.Text(Month(enddate) - 1, "00")
startday = Day(enddate)
startyear = Year(enddate)
enddate1 = "&d=" & startmonth & "&e=" & startday & "&f=" _
& startyear
'url1 forms the partial url that dictates the date range
url1 = startdate1 & enddate1
End Sub
Sub setupconnection()
'On error go to line with the words error1
On Error GoTo error1
Set ws = ActiveSheet
'Create a new spreadsheet to store connection
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = _
"Data Connection" & Worksheets.Count
Set ws1 = ActiveSheet
'Set url2 to the url you are surfing to
'REMEMBER to change goohoo.com to the real
'website
url2 = "http://finance.goohoo.com/q/hp?s=" & _
symbolrange(1, 1) & url1 & "&g=d&z=66&y=" & 0
'Add a connection
'REMEMBER to change goohoo.com to the real
'website
With ws1.QueryTables.Add(Connection:= _
"URL;http://finance.goohoo.com/q/hp?s=" & _
symbolrange(1, 1) & url1 & "&g=d&z=66&y=" & _
0, Destination:=ws1.Range("$A$1"))
.Name = "Hist_Data"
.FillAdjacentFormulas = False
.WebSelectionType = xlSpecifiedTables
.WebTables = "20"
.BackgroundQuery = False
.Refresh BackgroundQuery:=False
'You can remove the line for excel to wait if you
'successfully disable background query.
'Making Excel wait 3 seconds is very long
Application.Wait (Now() + TimeValue("00:00:03"))
End With
On Error GoTo 0
'Exit sub to prevent the macro from
'running the lines after error1 when
'there is no error.
Exit Sub
error1:
'Clear temp files
Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
Resume
End Sub
Sub grabdata()
On Error GoTo error1
For Each rcell In symbolrange
'Create a new spreadsheet to store each stock's data
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = _
rcell.Value & Worksheets.Count
Set ws2 = ActiveSheet
'Create a loop to keep grabbing data until complete
stock1 = rcell.Value
a = -1
Do
a = a + 1
'Remember to change goohoo.com
url2 = "http://finance.goohoo.com/q/hp?s=" & _
rcell.Value & url1 & "&g=d&z=66&y=" & a * 66
With ws1.QueryTables("Hist_Data")
.Connection = "URL;" & url2
.Refresh BackgroundQuery:=False
'You can remove the line for excel to wait if you
'successfully disable background query.
'Making Excel wait 3 seconds is very long
Application.Wait (Now() + TimeValue("00:00:03"))
End With
'Copy data onto correct spreadsheet
lastrow = ws2.Cells(65000, 1).End(xlUp).Row
If a = 0 Then
ws1.Range("Hist_Data").Copy
ws2.Cells(lastrow, 1).PasteSpecial xlPasteValuesAndNumberFormats
Else
ws1.Range("Hist_Data").Offset(1, 0).Copy
ws2.Cells(lastrow, 1).PasteSpecial xlPasteValuesAndNumberFormats
End If
Application.CutCopyMode = False
lastrow = ws2.Cells(65000, 1).End(xlUp).Row
Loop Until ws1.Cells(1, 1).Value = ws2.Cells(lastrow, 1).Value
Next rcell
On Error GoTo 0
'Exit sub to prevent the macro from
'running the lines after error1 when
'there is no error.
Exit Sub
error1:
Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
Resume
End Sub
You can download the sample code for Method A from here or (Alt Link). Click here to view Method B which is more flexible and, I believe, more efficient.
Note: Spreadsheets provided by finance4traders.blogspot.com are provided without warranty. Users should not be using them for any unlawful activity.
Some References
Information on error handling in VBA from Microsoft
Like what you have just read? Digg it or Tip'd it.
The objective of Finance4Traders is to help traders get started by bringing them unbiased research and ideas. Since late 2005, I have been developing trading strategies on a personal basis. Not all of these models are suitable for me, but other investors or traders might find them useful. After all, people have different investment/trading goals and habits. Thus, Finance4Traders becomes a convenient platform to disseminate my work...(Read more about Finance4Traders)
0 comments:
Post a Comment