从互联网导入多个CSV文件到Excel中

Question

我使用此代码检索约40个代码的历史股票价格。我在这里找到http://www.mathfinance.cn/download-multiple-stock-quotes-from-yahoo-finance

它会在运行时错误'1004'弹出之前下载大约一半的符号。 “无法打开http://table.finance.yahoo.com/table.csv?s=Tickersymbol&a=11&b=21&c=1998互联网网站报道，你要求的项目无法找到（HTTP/1.0 404）

我可以更改代码，以便不会发生这样的错误呢？代码如下

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

我不能让你的方法正常工作（我收到了几百个代号之后的内存错误）。

所以我对此感兴趣，并且挖了一点。我提出了另一种更复杂的方法，但效果更好（我在3分钟内上传了50012股S & P（Excel中的实际工作约3秒，其余为连接/下载时间）。一个模块中的全部代码，并运行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 

Answer 2

编辑：下面的代码解决您报告的问题，但很快我创造了另一种答案，我认为是更好的和强大的

它看起来像查询不被认可的内存用完。服务器，你可以添加一些呃如果遇到这样的错误，ror会检查以继续。

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 

你可能想要删除的表，而不是在它把一个错误消息或可能发送一个MsgBox，而不是...

Answer 3

我跑了一次，失败了。在查询行上放置一个断点，将雅虎地址加载到我的浏览器中，以确保它是有效的，然后脚本工作。我还确保项目中没有其他工作表。以下是VBA编辑器的屏幕截图以及断点位置：

您可以将变量粘贴到监视窗口中，然后用它来查看它的作用。如果您为此提出任何申请，我很乐意听到他们的消息！

Answer 4

附件是使用改良的重试之前最后检索高达3倍的自动收报机的数据（等待尝试之间几秒钟）的原码是“简单”的解决方案我的2美分:-)

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