我的网页查询宏问题 [英] Issues with My Web Query Macro

查看：269
本文介绍了我的网页查询宏问题的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

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

  Sub ThreeFinancialStatements（）
 
错误GoTo说明
 
 
 
行（2：1000）选择
 Selection.ClearContents 
列（B：AAT）选择
 
 
范围（Selection，Selection.End（xlToRight））。选择
 Selection.ClearContents 
 
 Dim inTicker As String 
 inTicker = Range A1）
 ActiveSheet.Name = UCase（inTicker）
 GetFinStats inTicker 
 
退出子
 
说明：
 MsgBox请请确保您在单元格A1中输入有效的股票代码，并且不会尝试创建重复的表格。 &安培; _ 
 vbLf& & _ 
 vbLf& 而且，对于具有不同类别股份的公司（例如伯克希尔哈撒韦公司），使用连字符来指定股票代码而不是期限（例如BRK-A）。 &安培; _ 
 vbLf& & _ 
 vbLf& 请注意，并不是每个公司都有三年的财务报表，所以有些公司的数据可能会出现不完整或缺失。_ 
，错误
 
退出子
 End Sub 
 
 
 Sub GetFinStats（inTicker As String）
'
'GetBalSheet宏
'
 
'
 
 
 
使用ActiveSheet.QueryTables.Add（Connection：= _ 
URL; http：//finance.yahoo.com/q/bs？s =& ; inTicker&+ Balance + Sheet& annual，目的地：= _ 
范围（$ D $ 1））
 .Name =bs？s = PEP +平衡+ 
 .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& +收入+声明和年度，目的地_ 
：=范围（$ J $ 1））
 .Name =is？s = PEP +收入+声明和年度
 .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 ActiveSh eet.QueryTables.Add（Connection：= _ 
URL; http：//finance.yahoo.com/q/cf？s =& inTicker& +现金+流量&年，目的地：= _ 
范围（$ P $ 1）
 .Name =cf？s = PEP +现金+流量&年
 .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 
结束
 
范围（A3）。选择
 ActiveCell.FormulaR1C1 =当前比率
范围（A4）。选择
 ActiveCell.FormulaR1C1 =快速比率
范围（A5）。选择
 ActiveCell.FormulaR1C1 =现金比率
范围（A6）。选择
 
范围（A7）。选择
 ActiveCell.FormulaR1C1 =收入增长率
范围（A9）。选择
列（A：A）。ColumnWidth = 21.86 
 ActiveCell.FormulaR1C1 =ROA
范围（A10）。 
 ActiveCell.FormulaR1C1 =ROE
范围（A11）。选择
 ActiveCell.FormulaR1C1 =ROIC
范围（B3）选择
选择
 ActiveCell.Formula ==（F11-F8）/ F28
范围（B5）选择
 ActiveCell.Formula == F5 / F28
范围（B7）。选择
 ActiveCell.Formula ==（L2 / N2）^（1/2） - 1
范围（B9）。选择
 ActiveCell.Formula == L35 / SUM（F12：F18）
范围（B10）选择
 ActiveCell .Formula == L35 / F 47
范围（B11）。选择
 ActiveCell.Formula == L35 /（F47 + SUM（F29：F33））
 
范围（B3 ）。选择
 Selection.NumberFormat =0.00
范围（B4）。选择
 
 Selection.NumberFormat =0.00
范围（B5 ）。选择
 Selection.NumberFormat =0.00
 
范围（B7）。选择
 Selection.NumberFormat =0.00％
范围（B9 ）。选择
 Selection.NumberFormat =0.00％
范围（B10）。选择
 Selection.NumberFormat =0.00％
范围（B11） 。选择
 Selection.NumberFormat =0.00％
范围（A1）。选择
 
 
 End Sub


解决方案

您仍然可以通过从


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



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





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

  IncomeStatementY 
 IncomeStatementQ 
 CashflowY 
 CashflowQ 
 BalanceSheetY 
 BalanceSheetQ 
 EarningsChartQ 
 FinancialsChartY 
 FinancialsChartQ

有了这个例子，您可以从该JSO中提取所需的数据N回应。


I wrote a Web Query macro to import financial statements from Yahoo Finance based on the value in cell A1. It was working seamlessly for the past few weeks, but suddenly, it no longer returns any data (but does not generate an error). If anyone has any insights, I would appreciate your guidance. I have posted the code below--thank you!

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

解决方案

You can still retrieve the necessary data by parsing JSON response either from

https://finance.yahoo.com/quote/AAPL/financials
(extracting data from HTML content, AAPL here just for example)

or via API

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

You may use the below VBA code to parse response and output result. Import JSON.bas module into the VBA project for JSON processing. Here are Sub Test_query1_finance_yahoo_com() to get data via API and Test_finance_yahoo_com_quote to extract data from HTML content:

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

Finally Sub QuoteDataOutput(vJSON) input is a JSON object, to make it clear how the necessary data is being extracted from it, you may save the JSON string to file, copy the contents and paste it to any JSON viewer for further study. I use online tool http://jsonviewer.stack.hu, target element structure is shown below:

The output for me is as follows (first worksheet shown):

There are 9 main sections, the relevant part of the data is extracted and output to 9 worksheets:

IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ

Having that example you can extract the data you need from that JSON response.

这篇关于我的网页查询宏问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
Office最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆