Я не могу заставить твой метод работать должным образом (я получаю ошибки памяти после нескольких сотен тиков).
Так что я заинтересовался и покопался немного дальше.Ниже я предлагаю другой подход, который является более сложным, но дает лучшие результаты (я загрузил 500 акций S & P за 3 минуты (около 3 секунд для фактической работы в Excel, остальное время соединения / загрузки). Просто скопируйте и вставьте всекод в модуле и запустить процедуру runBatch.
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