excel - 将多个 CSV 文件从 Internet 导入 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

编辑:下面的代码修复了您报告的问题，但很快就会耗尽内存。我创建了另一个我认为更好且更强大的答案

服务器似乎无法识别您的查询。如果遇到此类错误，您可以添加一些错误检查以继续。

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 代替...