Import multiple CSV files from Internet into Excel

Question

I use this code to retrieve historical stock prices for about 40 tickers. I found it here http://www.mathfinance.cn/download-multiple-stock-quotes-from-yahoo-finance

It downloads about half of the symbols before a Run-time Error '1004' pops up. "Unable to open http://table.finance.yahoo.com/table.csv?s=Tickersymbol&a=11&b=21&c=1998 The internet site reports that the item you requested cannot be found (HTTP/1.0 404)

Can I change the code so this error won't happen? The code is below

Sub Get_Yahoo_finance()

    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim Ticker As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim a, b, c, d, e, f
    Dim StrURL As String
    Set Sh = Worksheets("Input")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
    For Each Cell In Rng
        Ticker = Cell.Value
        StartDate = Cell.Offset(0, 1).Value
        EndDate = Cell.Offset(0, 2).Value
        a = Format(Month(StartDate) - 1, "00") '   Month minus 1
        b = Day(StartDate)
        c = Year(StartDate)
        d = Format(Month(EndDate) - 1, "00")
        e = Day(EndDate)
        f = Year(EndDate)
        StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
        StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
        StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
        StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
        If WorksheetExists(Ticker, ActiveWorkbook) Then
            Application.DisplayAlerts = False
            Sheets(Ticker).Select
            ActiveWindow.SelectedSheets.Delete
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        Else
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        End If
        With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
           .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = 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, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
            Array(7, 1))
        Range("A2").Select
        Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
        Columns("A:F").EntireColumn.AutoFit
    Next Cell
End Sub

Function WorksheetExists(SheetName As String, _
    Optional WhichBook As Workbook) As Boolean
    'from Chip Pearson
    Dim WB As Workbook
    Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
    On Error Resume Next
    WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

Answer 1

I can't get your method to work properly (I get out of memory errors after a few 100s of tickers).

So I got interested and dug a bit further. I propose another approach below which is more complex but yields better results (I uploaded the 500 stocks of the S&P in 3 minutes (about 3 seconds for the actual job in Excel, the rest is connection / download time). Just copy paste the whole code in a module and run the runBatch procedure.

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)

Private Declare Function URLDownloadToCacheFile Lib "urlmon" _
    Alias "URLDownloadToCacheFileA" (ByVal lpUnkcaller As Long, _
    ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwBufLength As Long, ByVal dwReserved As Long, _
    ByVal IBindStatusCallback As Long) As Long

Public Sub runBatch()
'Assumes there is a sheet called "Input" with 3 columns:
'Ticker, Start Date, End Date
'Actual data starts from Row 2

  Dim tickerData As Variant
  Dim ticker As String
  Dim url As String
  Dim i As Long
  Dim yahooData As Variant

  On Error GoTo error_handler
  Application.ScreenUpdating = False

  tickerData = Sheets("Input").UsedRange
  For i = LBound(tickerData, 1) + 1 To UBound(tickerData, 1) 'skip first row
    ticker = tickerData(i, 1)
    url = getYahooUrl(ticker, tickerData(i, 2), tickerData(i, 3))
    yahooData = getCsvContent(url)
    If isArrayEmpty(yahooData) Then
      MsgBox "No data found for " + ticker
    Else
      copyDataToSheet yahooData, ticker
    End If
  Next i

  Application.ScreenUpdating = True
  Exit Sub

error_handler:
  MsgBox "Error found while reading ticker [" + ticker + "]: " + Err.Description
  Application.ScreenUpdating = True

End Sub

Private Function getYahooUrl(ByVal ticker As String, ByVal startDate As Date, ByVal endDate As Date) As String

    Dim a As String
    Dim b As String
    Dim c As String
    Dim d As String
    Dim e As String
    Dim f As String

    a = Format(Month(startDate) - 1, "00") '   Month minus 1
    b = Day(startDate)
    c = Year(startDate)
    d = Format(Month(endDate) - 1, "00")
    e = Day(endDate)
    f = Year(endDate)

    getYahooUrl = "http://table.finance.yahoo.com/table.csv?" & _
                  "s=" & ticker & "&" & _
                  "a=" & a & "&" & _
                  "b=" & b & "&" & _
                  "c=" & c & "&" & _
                  "d=" & d & "&" & _
                  "e=" & e & "&" & _
                  "f=" & f & "&" & _
                  "g=d&ignore=.csv"

End Function

Private Function getCsvContent(url As String) As Variant

    Const RETRY_NUMS As Long = 3 'How m any times do we retry the download before giving up
    Dim szFileName As String
    Dim i As Long

    For i = 1 To RETRY_NUMS
      szFileName = Space$(300)
      If URLDownloadToCacheFile(0, url, szFileName, Len(szFileName), 0, 0) = 0 Then
        getCsvContent = getDataFromFile(Trim(szFileName), ",")
        Kill Trim(szFileName) 'to make sure data is refreshed next time
        Exit Function
      End If
      Sleep (500)
    Next i

End Function

Private Sub copyDataToSheet(data As Variant, sheetName As String)

  If Not WorksheetExists(sheetName) Then
    Worksheets.Add.Name = sheetName
  End If

  With Sheets(sheetName)
    .Cells.ClearContents
    .Cells(1, 1).Resize(UBound(data, 1), UBound(data, 2)) = data
    .Columns(1).NumberFormat = "d-mmm-yy"
    .Columns("A:F").AutoFit
  End With

End Sub

Private Function WorksheetExists(sheetName As String, Optional WhichBook As Workbook) As Boolean '
    'from Chip Pearson
    Dim WB As Workbook
    Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
    On Error Resume Next
    WorksheetExists = CBool(Len(WB.Worksheets(sheetName).Name) > 0)
End Function

Private Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)

  If IsArray(parArray) = False Then isArrayEmpty = True
  On Error Resume Next
  If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False

End Function

Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant 'V.20081021
'parFileName is supposed to be a delimited file (csv...)
'Returns an empty array if file is empty or can't be opened
'20081021: number of columns based on the line with the largest number of columns, not on the first line
'          parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
'20081022: Error Checks in place

  Dim locLinesList() As Variant
  Dim locData As Variant
  Dim i As Long
  Dim j As Long
  Dim locNumRows As Long
  Dim locNumCols As Long
  Dim fso As Variant
  Dim ts As Variant
  Const REDIM_STEP = 10000

  Set fso = CreateObject("Scripting.FileSystemObject")

  On Error GoTo error_open_file
  Set ts = fso.OpenTextFile(parFileName)
  On Error GoTo unhandled_error

  'Counts the number of lines and the largest number of columns
  ReDim locLinesList(1 To 1) As Variant
  i = 0
  Do While Not ts.AtEndOfStream
    If i Mod REDIM_STEP = 0 Then
      ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
    End If
    locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
    j = UBound(locLinesList(i + 1), 1) 'number of columns
    If locNumCols < j Then locNumCols = j
    i = i + 1
  Loop

  ts.Close

  locNumRows = i

  If locNumRows = 0 Then Exit Function 'Empty file

  ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant

  'Copies the file into an array
  If parExcludeCharacter <> "" Then

    For i = 1 To locNumRows
      For j = 0 To UBound(locLinesList(i), 1)
        If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
          If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
            locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2)       'If locTempArray = "", Mid returns ""
          Else
            locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
          End If
        ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
          locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
        End If
        locData(i, j + 1) = locLinesList(i)(j)
      Next j
    Next i

  Else

    For i = 1 To locNumRows
      For j = 0 To UBound(locLinesList(i), 1)
        locData(i, j + 1) = locLinesList(i)(j)
      Next j
    Next i

  End If

  getDataFromFile = locData

  Exit Function

error_open_file:     'returns empty variant
unhandled_error:     'returns empty variant

End Function

Answer 2

EDIT: The code below fixes the issue you reported but runs out of memory very quickly. I have created another answer which I think is much better and robust

It looks like your query is not recognised by the server. You can add some error checks to continue if such an error is encountered.

Sub Get_Yahoo_finance()

    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim Ticker As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim a, b, c, d, e, f
    Dim StrURL As String
    Dim errorMsg As String

    Set Sh = Worksheets("Input")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
    For Each Cell In Rng
        Ticker = Cell.Value
        StartDate = Cell.Offset(0, 1).Value
        EndDate = Cell.Offset(0, 2).Value
        a = Format(Month(StartDate) - 1, "00") '   Month minus 1
        b = Day(StartDate)
        c = Year(StartDate)
        d = Format(Month(EndDate) - 1, "00")
        e = Day(EndDate)
        f = Year(EndDate)
        StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
        StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
        StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
        StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
        If WorksheetExists(Ticker, ActiveWorkbook) Then
            Application.DisplayAlerts = False
            Sheets(Ticker).Select
            ActiveWindow.SelectedSheets.Delete
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        Else
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        End If
        With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
           .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            On Error Resume Next
            .Refresh BackgroundQuery:=False
            errorMsg = IIf(Err.Number = 0, "", Err.Description)
            On Error GoTo 0
        End With
        If errorMsg = "" Then
            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, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
                Array(7, 1))
            Range("A2").Select
            Range(Selection, Selection.End(xlDown)).NumberFormat = "d-mmm-yy"
            Columns("A:F").EntireColumn.AutoFit
        Else
            Range("A1") = errorMsg
        End If
    Next Cell

End Sub

Function WorksheetExists(SheetName As String, Optional WhichBook As Workbook) As Boolean '
    'from Chip Pearson
    Dim WB As Workbook
    Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
    On Error Resume Next
    WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

You might want to delete the sheet instead of putting an error message in it or maybe send a MsgBox instead...

Answer 3

I ran it once and it failed. Put a breakpoint on the query line, loaded the yahoo address into my browser to make sure it was valid, then the script worked. I also made sure that there were no other worksheets in the project. Here's a screenshot of the VBA editor and where the breakpoint goes:

You can stick the variable into a watch window and then fool around with it to see what it does. If you come up with any applications for this I'd love to hear about them!

Answer 4

Attached is a "simpler" solution using the original code modified to retry retrieving the ticker data upto 3 times (waiting a few seconds between attempts) before finally admitting failure by messagebox. My 2 cents :-)

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillisecond As Long)

Sub Get_Yahoo_finance_history()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim Ticker As String
    Dim StartDate As Date
    Dim EndDate As Date
    Dim a, b, c, d, e, f
    Dim StrURL As String
    Dim RetryCount As Integer

'turn calculation off
    'Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Set Sh = Worksheets("Input")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)

    For Each Cell In Rng
        Ticker = Cell.Value
        StartDate = Cell.Offset(0, 1).Value
        EndDate = Cell.Offset(0, 2).Value
        a = Format(Month(StartDate) - 1, "00") '   Month minus 1
        b = Day(StartDate)
        c = Year(StartDate)
        d = Format(Month(EndDate) - 1, "00")
        e = Day(EndDate)
        f = Year(EndDate)
        StrURL = "URL;http://table.finance.yahoo.com/table.csv?"
        StrURL = StrURL & "s=" & Ticker & "&a=" & a & "&b=" & b
        StrURL = StrURL & "&c=" & c & "&d=" & d & "&e=" & e
        StrURL = StrURL & "&f=" & f & "&g=d&ignore=.csv"
        If WorksheetExists(Ticker, ActiveWorkbook) Then
            Sheets(Ticker).Select
            ActiveWindow.SelectedSheets.Delete
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        Else
            ActiveWorkbook.Worksheets.Add.Name = Ticker
        End If
        RetryCount = 0 Retry:
        If RetryCount > 3 Then
            Range("A1") = errorMsg
            MsgBox "After 3 attempts: Could not retrieve data for " + Ticker
            End
        End If
        RetryCount = RetryCount + 1

        With ActiveSheet.QueryTables.Add(Connection:=StrURL, Destination:=Range("A1"))
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            On Error Resume Next
            .Refresh BackgroundQuery:=False
            errorMsg = IIf(Err.Number = 0, "", Err.Description)
            On Error GoTo 0
        End With
        If errorMsg = "" Then
           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, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
               Array(7, 1))
           Columns("A").EntireColumn.NumberFormat = "mm/dd/yyyy"
           Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
           Columns("F").EntireColumn.NumberFormat = "###,##0"
           Columns("B:E").EntireColumn.NumberFormat = "$###,##0.00"
           Columns("A:F").EntireColumn.AutoFit
        Else
           Sleep (500)
           Sheets(Ticker).Cells.ClearContents
           GoTo Retry
        End If
    Next Cell
     'turn calculation back on
    'Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
     End Sub

Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function