從互聯網導入多個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