'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 TKR.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
Const cQueryName = "YahooFinanceQuote" 'Name of the dynamic web query
Const cSymbolsFile = "C:\Temp\Excel\TickerSymbols.csv" 'File containing symbols to be retrieved, one per line
Const cSaveToFolder = "C:\Temp\Excel\" 'Folder in which to create the symbol.csv files
Const cIqyFile = "F:\Temp\Excel\YahooFinanceQuote.iqy" 'The .iqy file
Const cURL = "http://finance.yahoo.com/q?s=" 'Yahoo Finance URL with the query field (s=) but not the field value
Const cParameterCell = "B1" 'Cell containing the query field (s=) field value (Excel dynamic parameter)
Const cDataStartCell = "A2" 'Cell where retrieved data begins
Const cDataEndCell = "B31" 'Cell where retrieved data ends
Sub Retrieve_All_Symbols()
Dim fileNum As Integer
Dim symbol As String
Dim queryName As String
'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, cIqyFile, cParameterCell, cDataStartCell)
End If
fileNum = FreeFile
Open cSymbolsFile For Input As #fileNum
While Not EOF(fileNum)
Line Input #fileNum, symbol
'Put this quote symbol in the cell associated with the web query. This causes the web query to automatically refresh
'and retrieve the data for the symbol
ActiveSheet.Range(cParameterCell).Value = symbol
ActiveSheet.QueryTables(1).Refresh
'Save the data returned
Save_Stock_Data symbol, Range(cDataStartCell & ":" & cDataEndCell)
Wend
Close #fileNum
End Sub
Private Sub Save_Stock_Data(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 = cSaveToFolder & 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 = xlInsertDeleteCells
.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
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 = xlInsertDeleteCells
.RefreshStyle = xlOverwriteCells 'Was xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
.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
'=========== 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