我的 Web 查询宏的问题答案

【问题标题】：Issues with My Web Query Macro我的 Web 查询宏的问题
【发布时间】：2017-04-10 17:13:09
【问题描述】：

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

【问题讨论】：

您的代码隐含地依赖于 ActiveSheet 的特定工作表，但并不强制执行此操作。也许有人使用与打开工作表不同的工作表来保存工作簿？是的，这就是用.Select 和.Activate 编写的脆弱的VBA 代码。
谢谢。我应该如何改变它来解决这个问题？
@MichaelShore 您是否尝试在浏览器中手动打开 QueryTables 中的 URL？它们是否包含必要的数据？您能否发布预期的输出？
@MichaelShore this answer 可能会有所帮助，还请查看解析this JSON sample，似乎它包含您需要的所有数据。

标签： vba excel excel-web-query

【解决方案1】：

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

Rows("2:1000").Select

但那是什么纸？只有你知道。

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

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

Range
Cells
Columns
Rows
Names

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

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

这将.SelectDataSheet 对象指向的工作表上的指定行。

为什么你需要.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。

End Sub 标记之前的 Exit 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

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

您还可以为范围单元格设置数字格式：

.Range("B3:B11").NumberFormat = "0.00%"

【讨论】：

【解决方案2】：

您仍然可以通过解析来自

的 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 响应中提取所需的数据。

【讨论】：

【解决方案3】：

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

【讨论】：