3

我编写了一个 Web Query 宏来根据单元格 A1 中的值从 Yahoo Finance 导入财务报表。过去几周它一直在无缝运行，但突然间，它不再返回任何数据（但不会产生错误）。如果有人有任何见解，我将不胜感激您的指导。我已经在下面发布了代码-谢谢！

Sub ThreeFinancialStatements()

   On Error GoTo Explanation



   Rows("2:1000").Select
    Selection.ClearContents
    Columns("B:AAT").Select


    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents

    Dim inTicker As String
    inTicker = Range("A1")
    ActiveSheet.Name = UCase(inTicker)
    GetFinStats inTicker

    Exit Sub

Explanation:
   MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
   vbLf & " " & _
   vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
   vbLf & " " & _
   vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
  , "Error"

   Exit Sub
End Sub


Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'

'



    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
        Range("$D$1"))
        .Name = "bs?s=PEP+Balance+Sheet&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
        :=Range("$J$1"))
        .Name = "is?s=PEP+Income+Statement&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
        Range("$P$1"))
        .Name = "cf?s=PEP+Cash+Flow&annual"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "9"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With

    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Current Ratio"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Quick Ratio"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "Cash Ratio"
    Range("A6").Select

    Range("A7").Select
    ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
    Range("A9").Select
    Columns("A:A").ColumnWidth = 21.86
    ActiveCell.FormulaR1C1 = "ROA"
    Range("A10").Select
    ActiveCell.FormulaR1C1 = "ROE"
    Range("A11").Select
    ActiveCell.FormulaR1C1 = "ROIC"
    Range("B3").Select
    ActiveCell.Formula = "=F11/F28"
    Range("B4").Select
    ActiveCell.Formula = "=(F11-F8)/F28"
    Range("B5").Select
    ActiveCell.Formula = "=F5/F28"
    Range("B7").Select
    ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
    Range("B9").Select
    ActiveCell.Formula = "=L35/SUM(F12:F18)"
    Range("B10").Select
    ActiveCell.Formula = "=L35/F47"
    Range("B11").Select
    ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"

    Range("B3").Select
    Selection.NumberFormat = "0.00"
    Range("B4").Select

    Selection.NumberFormat = "0.00"
    Range("B5").Select
    Selection.NumberFormat = "0.00"

    Range("B7").Select
    Selection.NumberFormat = "0.00%"
    Range("B9").Select
    Selection.NumberFormat = "0.00%"
    Range("B10").Select
    Selection.NumberFormat = "0.00%"
    Range("B11").Select
    Selection.NumberFormat = "0.00%"
    Range("A1").Select


End Sub
4

3 回答 3

1

您仍然可以通过解析 JSON 响应来检索必要的数据

https://finance.yahoo.com/quote/AAPL/financials
（从 HTML 内容中提取数据，此处为 AAPL 示例）

或通过 API

https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings

您可以使用下面的 VBA 代码来解析响应和输出结果。将 JSON.bas模块导入VBA 项目以进行 JSON 处理。下面是Sub Test_query1_finance_yahoo_com()通过 API 获取数据并Test_finance_yahoo_com_quote从 HTML 内容中提取数据：

Option Explicit

Sub Test_query1_finance_yahoo_com()

    Dim sSymbol As String
    Dim sJSONString As String
    Dim vJSON As Variant
    Dim sState As String

    sSymbol = "AAPL"

    ' Get JSON via API
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
        .Send
        sJSONString = .ResponseText
    End With
    ' Parse JSON response
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then
        MsgBox "Invalid JSON"
        Exit Sub
    End If
    ' Pick core data
    Set vJSON = vJSON("quoteSummary")("result")(0)
    ' Output
    QuoteDataOutput vJSON
    MsgBox "Completed"

End Sub

Sub Test_finance_yahoo_com_quote()

    Dim sSymbol As String
    Dim sJSONString As String
    Dim vJSON As Variant
    Dim sState As String

    sSymbol = "AAPL"

    ' Get webpage HTML response
    With CreateObject("Msxml2.XMLHTTP")
        .Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
        .Send
        sJSONString = .ResponseText
    End With
    ' Extract JSON from HTML content
    sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
    sJSONString = Split(sJSONString, "}(this));")(0)
    sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
    ' Parse JSON response
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then
        MsgBox "Invalid JSON"
        Exit Sub
    End If
    ' Pick core data
    Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
    ' Output
    QuoteDataOutput vJSON
    MsgBox "Completed"

End Sub

Sub QuoteDataOutput(vJSON)

    Const Transposed = True ' Output option

    Dim oItems As Object
    Dim vItem
    Dim aRows()
    Dim aHeader()

    ' Fetch main structures available from JSON object to dictionary
    Set oItems = CreateObject("Scripting.Dictionary")
    With oItems
        .Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
        .Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
        .Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
        .Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
        .Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
        .Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
        .Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
        .Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
        .Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
    End With
    ' Output each data set to separate worksheet
    For Each vItem In oItems
        ' Convert each data set to array
        JSON.ToArray oItems(vItem), aRows, aHeader
        ' Output array to worksheet
        With GetSheet((vItem))
            .Cells.Delete
            If Transposed Then
                Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
                Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
            Else
                OutputArray .Cells(1, 1), aHeader
                Output2DArray .Cells(2, 1), aRows
            End If
            .Columns.AutoFit
        End With
    Next

End Sub

Function GetSheet(sName As String, Optional bCreate = True) As Worksheet

    On Error Resume Next
    Set GetSheet = ThisWorkbook.Sheets(sName)
    If Err Then
        If bCreate Then
            Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            GetSheet.Name = sName
        End If
        Err.Clear
    End If

End Function

Sub OutputArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

Sub Output2DArray(oDstRng As Range, aCells As Variant)

    With oDstRng
        .Parent.Select
        With .Resize( _
                UBound(aCells, 1) - LBound(aCells, 1) + 1, _
                UBound(aCells, 2) - LBound(aCells, 2) + 1)
            .NumberFormat = "@"
            .Value = aCells
        End With
    End With

End Sub

最后Sub QuoteDataOutput(vJSON)输入是一个 JSON 对象，为了清楚说明如何从中提取必要的数据，您可以将 JSON 字符串保存到文件中，复制内容并将其粘贴到任何 JSON 查看器中以供进一步研究。我使用在线工具http://jsonviewer.stack.hu，目标元素结构如下图所示：

JSON结构

我的输出如下（显示的第一个工作表）：

输出

有9个主要部分，提取数据的相关部分并输出到9个工作表：

IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ

有了该示例，您可以从该 JSON 响应中提取所需的数据。

于 2017-04-14T22:47:02.867 回答
1

您的代码显然是针对特定工作表的：

Rows("2:1000").Select

但那是什么单子？只有你能知道。

正如所写，它是任何活动工作表，无论它有多大意义。

不合格，这些函数都隐含地引用了ActiveSheet：

  • Range
  • Cells
  • Columns
  • Rows
  • Names

所以你需要给他们资格。你可以通过指定Worksheet他们应该使用的特定对象来做到这一点——假设是DataSheet（我不知道）：

DataSheet.Rows("2:1000").Select

这将是对象指向的工作表上.Select的指定行。DataSheet

你为什么需要.Select它？这个：

Rows("2:1000").Select
Selection.ClearContents

也可以是：

DataSheet.Rows("2:1000").ClearContents

或者更好 - 假设您的数据被格式化为表格（看起来它看起来像一个表格 - 那么为什么不使用ListObjectsAPI？）：

DataSheet.ListObjects("DataTable").DataBodyRange.Delete

听起来那条指令刚刚取代了所有的.Select并.ClearContents继续在这里。请注意，.Select模仿用户操作 - 用户单击一个单元格（或任何真正的东西）并选择它。您可以通过编程方式访问整个对象模型——您永远不需要任何.Select东西！

Dim inTicker As String
inTicker = Range("A1")

在这里，您隐式地从活动工作表中读取，但您也隐式地将 a Variant（单元格的值）转换为 a String，这可能会也可能不会成功。如果A1包含错误值（例如#REF!），则指令失败。

With DataSheet.Range("A1")
    If Not IsError(.Value) Then 
        inTicker = CStr(.Value)
    Else
        'decide what to do then
    End If
End With

您的错误处理子例程至少 Debug.Print Err.Number, Err.Description应该让您对事情发生的原因有一点线索。现在它假设失败的原因，正如你所看到的，Excel 充满了陷阱。

您也在使用vbLf，但这只是正确的 Windows换行符的一半。vbNewLine如果您不确定那是什么，请使用。

Exit Sub令牌之前的指令完全End Sub没有用。

Sub GetFinStats(inTicker As String)

该过程是隐式的Public，并且inTicker是隐式传递ByRef的。感谢给它一个明确的类型！

这会更好：

Private Sub GetFinStats(ByVal inTicker As String)

With ActiveSheet.QueryTables

至少这是关于使用活动工作表的明确说明。但它应该使用活动工作表还是特定工作表？已经存在的查询表会发生什么？

我强烈建议您在直接窗格中键入：

?ThisWorkbook.Connections.Count

如果该数量大于.QueryTables.Add您在程序中的呼叫数量（可能），那么您有一个很大的问题：我怀疑您在工作簿中有超过一百个连接，并且单击“全部刷新”按钮需要永远完成，并且很有可能finance.yahoo.com在非常有限的时间内收到来自单个 IP 的数十个请求，并且拒绝为它们提供服务。

删除所有未使用的工作簿连接。然后也修复ActiveSheet那里的隐式引用，并摆脱所有这些无用的.Select调用：

With TheSpecificSheet

    With .QueryTables.Add( ... )
    End With

    With .QueryTables.Add( ... )
    End With

    With .QueryTables.Add( ... )
    End With

    'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
    .Range("A3").Value = "Current Ratio"
    .Range("A4").Value = "Quick Ratio"
    .Range("A5").Value = "Cash Ratio"

End With

连续.Select的调用意味着除了最后一个之外的所有调用都有一个目的，如果有的话：

Range("A6").Select
Range("A7").Select

ActiveCell同样，当您可以.Range("A7").Value直接分配时不要分配。

您可以为一系列单元格设置数字格式：

.Range("B3:B11").NumberFormat = "0.00%"
于 2017-04-10T17:56:34.207 回答
0

事实证明，Yahoo 终止了 Web 查询从中提取数据的应用程序。谢谢你的所有提示。

于 2017-04-11T03:22:40.770 回答