Question

我写了一个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

Answer 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

或者更好 - 假设您的数据格式化为表（似乎看起来像一样 - 所以为什么不使用ListObjects API？）：

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

听起来这条指令刚刚替换了此处发生的所有.Select和.ClearContents。请注意.Select模仿用户操作 - 用户点击某个单元格（或任何其他内容）并选择它。您可以以编程方式访问整个对象模型 - 您从不需要到.Select任何东西！

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

这里你隐含地从活动表中读取，但你也隐含地将Variant（单元格的值）转换为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的数十个请求，并拒绝为它们提供服务。” / p>
删除所有未使用的工作簿连接。然后在那里修复隐含的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%"

Answer 2

事实证明，雅虎结束了Web查询从中提取数据的应用程序。感谢您的所有提示。

Answer 3

您仍然可以通过从

解析JSON响应来检索必要的数据

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

或通过API

https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US&region=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，目标元素结构如下所示：

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

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

IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ

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

我的Web查询宏的问题

3 个答案: