'Uses a dynamic web query, using either an .iqy file or a URL connection string, to retrieve stock data from
'Yahoo Finance (http://finance.yahoo.com).
'The stock quote symbols are read from a file containing one symbol per line.
'For each symbol, the stock data is retrieved using the dynamic web query and then saved in a file called .csv.
'The dynamic web query is contained in the file YahooFinanceQuote.iqy, which contains:
' WEB
' 1
' http://finance.yahoo.com/q?s=["quote symbol","Enter cell containing quote symbol, e.g. =B1"]&=
Option Explicit
'Name of the dynamic web query
Const cQueryName = "YahooFinanceQuote"
'File containing symbols to be retrieved, one per line.
'Const cSymbolsFilename = "Yahoo Finance TickerSymbols.csv"
Const cSymbolsFilename = "TickerSymbols.csv"
'Folder containing the symbols file
Const cSymbolsFolder = "Z:\WebSpider\"
'Folder in which to create the symbol.csv files. This folder must exist
Const cSaveToFolder = "Z:\WebSpider\Yahoo Financial\Data\"
'The .iqy file. This file should be in the same folder as the workbook. Not used if URL web query is called.
Const cIqyFilename = "IQYImport.iqy"
'Yahoo Finance URL with the query field (s=) but not the field value
'Const cURL = "http://finance.yahoo.com/q?s="
'Cell containing the query field (s=) field value (Excel dynamic parameter)
Const cParameterCell = "B1"
'Cell where retrieved data begins
Const cDataStartCell = "A2"
'Delete temporary internet files every n symbols
Const cDeleteTemporaryFilesEvery = 20
'For debugging
Const cDEBUG = True
Public Sub Retrieve_All_Symbols()
Dim symbolsFile As String
Dim iqyFile As String
Dim saveToFolder As String
Dim fileNum As Integer
Dim symbol As String
Dim queryName As String
Dim dataEndRow As Integer
Dim s As Integer
Dim numSymbols As Long
symbolsFile = cSymbolsFolder & cSymbolsFilename
'Or if the symbols file is in the same folder as the workbook
'symbolsFile = ActiveWorkbook.Path & "\" & cSymbolsFilename
iqyFile = ActiveWorkbook.Path & "\" & cIqyFilename
saveToFolder = cSaveToFolder
'Or to save the symbol.csv files in the same folder as the workbook
'saveToFolder = ActiveWorkbook.Path & "\"
'Get web query (if it has been created manually) and create it if it doesn't exist
queryName = Get_Web_Query_Name
If queryName = "" Then
'queryName = Create_Dynamic_Query_From_URL(cQueryName, cURL, cParameterCell, cDataStartCell)
queryName = Create_Dynamic_Query_From_Iqy_File(cQueryName, iqyFile, cParameterCell, cDataStartCell)
End If
numSymbols = 0
fileNum = FreeFile
Open symbolsFile For Input As #fileNum
While Not EOF(fileNum)
DoEvents
Line Input #fileNum, symbol
numSymbols = numSymbols + 1
If cDEBUG Then Debug.Print numSymbols & " " & symbol
'Put this quote symbol in the cell associated with the web query.
'The web query doesn't automatically refresh, despite the RefreshOnChange property being set. Therefore the
'explicit Refresh below is required to retrieve the data for the symbol
ActiveSheet.Range(cParameterCell).Value = symbol
'Delisted ticker symbols such as AQR-U cause the web query to
'return "Run-time error 1004, This web query returned no data ..."
'because the quote page (e.g. http://finance.yahoo.com/q?s=AQR-U&=) contains no tables
On Error Resume Next
ActiveSheet.QueryTables(queryName).Refresh BackgroundQuery:=False
If Err.Number = 0 Then
'No error occurred
On Error GoTo 0
If cDEBUG Then Debug.Print "Retrieved OK"
'Find the last row of data in column A
dataEndRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
'Save the data returned
Save_Stock_Data saveToFolder, symbol, Range("A2:B" & dataEndRow)
ElseIf Err.Number = 1004 Then
'The expected error "This web query returned no data ..." occurred - ignore it
On Error GoTo 0
If cDEBUG Then Debug.Print "Web query returned no data"
Else
'An unexpected error occurred - tell the user
On Error GoTo 0
If cDEBUG Then Debug.Print "Error " & Err.Number & " " & Err.Description
MsgBox "Error number " & Err.Number & vbNewLine & Err.Description, , "Run-time error"
End If
DoEvents
'Every n symbols delete Yahoo Finance files from IE temporary internet files cache
'Without this, after a while any web query, even a manual one, returns
' "Run-time error 1004 The file could not be accessed ...",
'which is trapped by the error handler above.
'It seems that this error is related to IE's temporary internet files -
'see http://www.vbforums.com/showthread.php?t=453684 for other people with the same problem with Yahoo Finance quotes.
'The solution is to periodically delete the temporary files that IE creates for
'http://finance.yahoo.com/q?s=XXX
If numSymbols Mod cDeleteTemporaryFilesEvery = 0 Then
Delete_Yahoo_IE_Temporary_Files
DoEvents
End If
Wend
Close #fileNum
End Sub
Private Sub Save_Stock_Data(folder As String, symbol As String, dataRange As Range)
'Save the stock data for the symbol in the file .csv
Dim dataOutputFile As String
Dim fileNum As Integer
Dim csvLine As String
Dim previousRow As Integer
Dim cell As Range
dataOutputFile = folder & symbol & ".csv"
fileNum = FreeFile
Open dataOutputFile For Output As #fileNum
csvLine = ""
previousRow = dataRange.Row
For Each cell In dataRange
If cell.Row = previousRow Then
csvLine = csvLine & cell.Value & ","
Else
Print #fileNum, Left(csvLine, Len(csvLine) - 1)
csvLine = cell.Value & ","
previousRow = cell.Row
End If
Next
Print #fileNum, Left(csvLine, Len(csvLine) - 1)
Close #fileNum
End Sub
Private Function Create_Dynamic_Query_From_URL(queryName As String, URL As String, parameterCell As String, _
destinationCell As String) As String
Dim qt As QueryTable
Dim URLquery As String
'Code in this function was generated by the Macro Recorder as a result of
'Data - Import External Data - Import Data - browse to .iqy file.
'and then modified to include the quote symbol parameter in the connection string - see http://www.jkp-ads.com/Articles/WebQuery.asp
'Therefore the .iqy file is not needed and the Parameter Value dialogue box doesn't appear when the querytable is added.
'This is the URL from the .iqy file
'http://finance.yahoo.com/q?s=["quote symbol","Enter cell containing quote symbol, e.g. =B1"]&=
URLquery = "[""quote symbol"",""Enter cell containing quote symbol, e.g. =B1""]&="
Set qt = ActiveSheet.QueryTables.Add(Connection:="URL;" & URL & URLquery, Destination:=Range(destinationCell))
With qt
.Name = queryName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False 'False because data requests must be synchronous. Was True when generated by Macro Recorder
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
With .Parameters(1)
.SetParam xlRange, ActiveSheet.Range(parameterCell)
.RefreshOnChange = True 'But doesn't trigger an automatic refresh when value of parameter cell changes
End With
'.Refresh BackgroundQuery:=False
End With
Create_Dynamic_Query_From_URL = qt.Name
End Function
Private Function Create_Dynamic_Query_From_Iqy_File(queryName As String, iqyFile As String, parameterCell As String, _
destinationCell As String) As String
Dim qt As QueryTable
'Code in this function was generated by the Macro Recorder as a result of
'Data - Import External Data - Import Data - browse to .iqy file
'and then modified to suit this program
Set qt = ActiveSheet.QueryTables.Add(Connection:="FINDER;" & iqyFile, Destination:=Range(destinationCell))
With qt
.Name = queryName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False 'False because data requests must be synchronous. Was True when generated by Macro Recorder
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
'This With ... End With block sets the web query's parameter value to the specified cell. Without this,
'the 'Set Parameter Value' dialogue box appears
'With .Parameters(1)
' .SetParam xlRange, ActiveSheet.Range(parameterCell)
' .RefreshOnChange = True
'End With
.Refresh BackgroundQuery:=False
End With
Create_Dynamic_Query_From_Iqy_File = qt.Name
End Function
Private Function Get_Web_Query_Name() As String
Dim qt As QueryTable
'Returns the name of the first web query on the active sheet, or "" if no queries exist
If ActiveSheet.QueryTables.Count > 0 Then
Get_Web_Query_Name = ActiveSheet.QueryTables(1).Name
Else
Get_Web_Query_Name = ""
End If
End Function
Private Sub Delete_Yahoo_IE_Temporary_Files()
'Delete Yahoo Finance files (filenames matching q[*.* and lookup*.*) from the IE cache
Static TemporaryInternetFilesPath As String
Static ComSpec As String
Dim oWSH As Object
Dim IECacheKey As String
Dim ShellXResult As Long
Dim DOScommand As String
If TemporaryInternetFilesPath = "" Then
IECacheKey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Cache"
Set oWSH = CreateObject("WScript.Shell")
TemporaryInternetFilesPath = oWSH.RegRead(IECacheKey) & "\Content.IE5\"
End If
If ComSpec = "" Then ComSpec = Environ$("ComSpec")
'Run DEL commands asynchronously
DOScommand = "DEL /Q /S " & Chr(34) & TemporaryInternetFilesPath & "q[*.*" & Chr(34)
Shell ComSpec & " /c " & DOScommand, vbHide
DOScommand = "DEL /Q /S " & Chr(34) & TemporaryInternetFilesPath & "lookup*.*" & Chr(34)
Shell ComSpec & " /c " & DOScommand, vbHide
'May need synchronous Shell function instead - http://vb-tec.de/xshell.htm
'ShellXResult = ShellX(ComSpec & " /c " & DOScommand, vbHide)
End Sub
'=========== Debugging and Information routines ===========
Private Sub Show_All_Queries()
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
Debug.Print qt.Name
Next
End Sub
Private Sub Delete_Query(queryName As String)
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
If qt.Name = queryName Then qt.Delete
Next
End Sub
Sub Delete_All_Queries()
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
Debug.Print "Deleted " & qt.Name
qt.Delete
Next
End Sub
