' ActiveQuotesDownload VBA Module ' ' This VBA module automatically download stock quotes from Yahoo Finance (http://finance.yahoo.com) ' ' Copyright 2009-2010, ConnectCode ' http://spreadsheetml.com/ ' This module is dual licensed under the MIT or GPL Version 2 licenses. ' Sub ActiveQuotesDownload() Call GetStock("YHOO", "01/01/2009", "03/01/2009") 'Parameters : Stock Symbol, Start Date (MM/DD/YYYY), End Date (MM/DD/YYYY) 'Call GetStock("YHOO", "01/01/2009", "03/03/2009","d") 'Additional Parameter (Stock Frequency : d - day, w - week, m - month) 'Call GetStock("YHOO", "01/01/2009", "03/03/2009","d","y") 'Additional Parameter (Swap Adjusted Close : y - yes, n - no) 'Call GetStock("YHOO", "01/01/2009", "03/03/2009","d","y","Sheet1") 'Additional Parameter (Worksheet Name : Download Stock quotes to the specified worksheet) End Sub Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean On Error Resume Next WorksheetExists = (Sheets(WorksheetName).Name <> "") On Error GoTo 0 End Function Sub GetStock(ByVal stockSymbol As String, ByVal sDate As String, ByVal eDate As String, Optional ByVal freq As String = "d", Optional ByVal swap As String = "n", Optional ByVal destiSheet As String = "DownloadedData") Dim StartDate As Date Dim EndDate As Date StartDate = Format(sDate, "MM/DD/YYYY") EndDate = Format(eDate, "MM/DD/YYYY") Dim wsExist As Boolean wsExist = WorksheetExists(destiSheet) If (wsExist = False) Then If (destiSheet = "DownloadedData") Then Worksheets.Add().Name = "DownloadedData" Else MsgBox ("Worksheet does not exist.") Exit Sub End If End If Worksheets(destiSheet).Select Worksheets(destiSheet).UsedRange.Clear Dim desti As String Dim noErrorFound As Integer Dim DownloadURL As String Dim StartMonth, StartDay, StartYear, EndMonth, EndDay, EndYear As String StartMonth = Format(Month(StartDate) - 1, "00") StartDay = Format(Day(StartDate), "00") StartYear = Format(Year(StartDate), "00") noErrorFound = 0 desti = "$A$1" EndMonth = Format(Month(EndDate) - 1, "00") EndDay = Format(Day(EndDate), "00") EndYear = Format(Year(EndDate), "00") DownloadURL = "URL;http://table.finance.yahoo.com/table.csv?s=" + stockSymbol + "&a=" + StartMonth + "&b=" + StartDay + "&c=" + StartYear + "&d=" + EndMonth + "&e=" + EndDay + "&f=" + EndYear + "&g=" + freq + "&ignore=.csv" On Error GoTo ErrHandler: With ActiveSheet.QueryTables.Add(Connection:=DownloadURL, Destination:=Range(desti)) .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = "20" .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _ :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _ Array(7, 1)) Columns("A:G").EntireColumn.AutoFit If (vvx >= 12) Then 'Excel 2007 ActiveWorkbook.Worksheets(destiSheet).Sort.SortFields.Clear ActiveWorkbook.Worksheets(destiSheet).Sort.SortFields.Add Key:=Range("A2:A6550") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets(destiSheet).Sort .SetRange Range("A1:G65500") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Else 'Excel 2003 Columns("A:G").Select Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End If If (swap = "y") Then Call SwapCloseAndAdjustedClose(destiSheet) End If noErrorFound = 1 ErrHandler: If noErrorFound = 0 Then MsgBox ("Error in Getting Quotes.") End If End Sub Sub SwapCloseAndAdjustedClose(Optional ByVal destiSheet As String = "DownloadedData") Application.ScreenUpdating = False 'Find the number of rows of stock data M = 2 numRowsData = 0 Do While M < 65000 shtName = outputShtName If Worksheets(destiSheet).Cells(M, 1) = "" Then numRowsData = M - 1 - 1 'Additional Blank Lines M = 65000 End If M = M + 1 Loop Dim vvx As Integer vvx = Application.Version If (vvx >= 12) Then 'Excel 2007 Worksheets(destiSheet).Range("DA1:DA" & numRowsData) = Worksheets(destiSheet).Range("E1:E" & numRowsData).Value Worksheets(destiSheet).Range("E1:E" & numRowsData) = Worksheets(destiSheet).Range("G1:G" & numRowsData).Value Worksheets(destiSheet).Range("G1:G" & numRowsData) = Worksheets(destiSheet).Range("DA1:DA" & numRowsData).Value Worksheets(destiSheet).Range("DA1:DA" & numRowsData) = Worksheets(destiSheet).Range("DB1:DB" & numRowsData).Value Else 'Excel 2003 Worksheets(destiSheet).Range("E1:E" & numRowsData).Copy Destination:=Worksheets(destiSheet).Range("DA1") Worksheets(destiSheet).Range("G1:G" & numRowsData).Copy Destination:=Worksheets(destiSheet).Range("E1") Worksheets(destiSheet).Range("DA1:DA" & numRowsData).Copy Destination:=Worksheets(destiSheet).Range("G1") Worksheets(destiSheet).Range("DB1:DB" & numRowsData).Copy Destination:=Worksheets(destiSheet).Range("DA1") End If Application.ScreenUpdating = True End Sub