1. 技术文章
  2. Issues with My Web Query Macro

Issues with My Web Query Macro

由 穿精又带淫゛_ 提交于 2019-11-26 03:45:48

问题


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

回答1:


Your code is obviously working against a specific worksheet:

Rows("2:1000").Select

But what sheet is that? Only you can know that.

As written, it's whatever the active worksheet is, regardless of how much sense that makes.

Unqualified, these functions all implicitly refer to the ActiveSheet:

  • Range
  • Cells
  • Columns
  • Rows
  • Names

So you need to qualify them. And you do that by specifying a specific Worksheet object they should be working with - suppose that's DataSheet (I've no idea):

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

That would .Select the specified rows on the worksheet pointed to by the DataSheet object.

By why do you need to .Select it? This:

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

Could just as well be:

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

Or better - assuming your data is formatted as a table (seems it looks like one anyway - so why not use the ListObjects API?):

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

Sounds like that instruction has just replaced all the .Select and .ClearContents going on here. Note that .Select mimicks user action - the user clicking on a cell (or anything really) and selecting it. You have programmatic access to the entire object model - you never need to .Select anything!

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

Here you're implicitly reading from the active sheet, but you're also implicitly converting a Variant (the cell's value) into a String, which may or may not succeed. If A1 contains an error value (e.g. #REF!), the instruction fails.

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

Your error-handling subroutine should at least Debug.Print Err.Number, Err.Description so that you have a bit of a clue about why things blew up. Right now it's assuming a reason for failure, and as you saw, Excel is full of traps.

Also you're using vbLf, but that's only half of a proper Windows newline character. Use vbNewLine if you're not sure what that is.

An Exit Sub instruction just before an End Sub token is completely useless.

Sub GetFinStats(inTicker As String)

The procedure is implicitly Public, and inTicker is implicitly passed ByRef. Kudos for giving it an explicit type!

This would be better:

Private Sub GetFinStats(ByVal inTicker As String)

With ActiveSheet.QueryTables

At least that's explicit about using the active sheet. But should it use the active sheet, or a specific sheet? And what happens to the query tables that were already there?

I strongly recommend you type this in the immediate pane:

?ThisWorkbook.Connections.Count

If the number is greater than the number of .QueryTables.Add calls you have in your procedure (likely), you have quite a problem there: I suspect you have over a hundred connections in the workbook, and clicking the "Refresh All" button takes forever to finish, and it's fairly possible that finance.yahoo.com is receiving dozens of requests from a single IP in a very limited amount of time, and refuses to serve them.

Delete all unused workbook connections. And then fix the implicit ActiveSheet references there too, and get rid of all these useless .Select calls:

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

Consecutive .Select calls mean all but the last one serve a purpose, if any:

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

Again, don't assign ActiveCell when you can assign .Range("A7").Value directly.

And you can set number formats for a range of cells:

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



回答2:


It turns out that Yahoo ended the application from which the web query drew its data. Thank you for all your tips.




回答3:


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.



来源：https://stackoverflow.com/questions/43329177/issues-with-my-web-query-macro

标签
excel
vba
excel-vba
excel-web-query
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!