问题
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
回答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
回答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...
回答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!
回答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
来源：https://stackoverflow.com/questions/9366639/import-multiple-csv-files-from-internet-into-excel