excel - Problemas con mi macro de consulta web

vba excel-vba

Question

Escribí una macro de Web Query para importar estados financieros de Yahoo Finance en función del valor en la celda A1. Funcionó sin problemas durante las últimas semanas, pero de repente, ya no devuelve ningún dato (pero no genera un error). Si alguien tiene alguna idea, agradecería su orientación. He publicado el código a continuación, ¡gracias!

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

Aún puede recuperar los datos necesarios analizando la respuesta JSON desde

https://finance.yahoo.com/quote/AAPL/financials
(extrayendo datos del contenido HTML, AAPL aquí solo por ejemplo)

o vía API

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

Puede usar el siguiente código de VBA para analizar la respuesta y el resultado de salida. Importe el módulo JSON.bas al proyecto VBA para el procesamiento JSON. Aquí están Sub Test_query1_finance_yahoo_com() para obtener datos a través de API y Test_finance_yahoo_com_quote para extraer datos del contenido 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

Finalmente, la entrada Sub QuoteDataOutput(vJSON) es un objeto JSON, para que quede claro cómo se extraen los datos necesarios, puede guardar la cadena JSON en el archivo, copiar el contenido y pegarlo en cualquier visor JSON para su posterior estudio. Utilizo la herramienta en línea http://jsonviewer.stack.hu , la estructura del elemento de destino se muestra a continuación:

El resultado para mí es el siguiente (se muestra la primera hoja de trabajo):

Hay 9 secciones principales, la parte relevante de los datos se extrae y se envía a 9 hojas de trabajo:

IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ

Teniendo ese ejemplo, puede extraer los datos que necesita de esa respuesta JSON.

Answer 2

Resulta que Yahoo finalizó la aplicación de la cual la consulta web extrajo sus datos. Gracias por todos tus consejos.

Answer 3

Su código obviamente está trabajando contra una hoja de trabajo específica:

Rows("2:1000").Select

¿Pero qué hoja es esa? Solo tú puedes saber eso.

Tal como está escrito, es lo que sea ​​la hoja de trabajo activa , independientemente del sentido que tenga.

Sin calificar, todas estas funciones se refieren implícitamente a ActiveSheet :

• Range
• Cells
• Columns
• Rows
• Names

Entonces necesitas calificarlos . Y lo haces especificando un objeto de Worksheet específico con el que deberían estar trabajando; supongamos que es DataSheet (no tengo idea):

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

Eso seleccionaría las filas especificadas en la hoja de trabajo a la que apunta el objeto DataSheet .

¿ Por qué necesita seleccionarlo? Esta:

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

También podría ser:

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

O mejor, suponiendo que sus datos ListObjects formateados como una tabla (parece que de todos modos parece una, así que ¿por qué no usar la API ListObjects ?):

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

Parece que esa instrucción acaba de reemplazar todos los contenidos .ClearContents y .ClearContents que .ClearContents sucediendo aquí. Tenga en cuenta que .Select imita la acción del usuario: el usuario hace clic en una celda (o cualquier cosa realmente) y la selecciona . Usted tiene acceso programático a todo el modelo de objetos ; nunca necesita. ¡ .Select cualquier cosa!

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

Aquí está leyendo implícitamente la hoja activa, pero también está convirtiendo implícitamente una Variant (el valor de la celda) en una String , que puede tener éxito o no. Si A1 contiene un valor de error (por ejemplo, #REF! ), La instrucción falla.

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

Su subrutina de manejo de errores debe al menos Debug.Print Err.Number, Err.Description para que tenga una idea de por qué las cosas explotaron. En este momento está asumiendo una razón para el fracaso, y como viste, Excel está lleno de trampas.

También está usando vbLf , pero eso es solo la mitad de un personaje de nueva línea de Windows adecuado. Use vbNewLine si no está seguro de qué es eso.

Una instrucción Exit Sub justo antes de un token End Sub es completamente inútil.

Sub GetFinStats(inTicker As String)

El procedimiento es implícitamente Public e inTicker se pasa implícitamente por ByRef . ¡Felicitaciones por darle un tipo explícito!

Esto sería mejor:

Private Sub GetFinStats(ByVal inTicker As String)

With ActiveSheet.QueryTables

Al menos eso es explícito sobre el uso de la hoja activa. Pero, ¿debería usar la hoja activa o una hoja específica? ¿Y qué pasa con las tablas de consulta que ya estaban allí?

Le recomiendo que escriba esto en el panel inmediato :

?ThisWorkbook.Connections.Count

Si el número es mayor que el número de .QueryTables.Add llamadas que tiene en su procedimiento (probablemente), tiene un problema: sospecho que tiene más de cien conexiones en el libro y hace clic en el botón "Actualizar todo" Tarda una eternidad en terminar, y es bastante posible que finance.yahoo.com reciba docenas de solicitudes de una sola IP en un tiempo muy limitado y se niegue a atenderlas.

Eliminar todas las conexiones de libro no utilizadas. Y luego arregle las referencias implícitas de ActiveSheet allí también, y elimine todas estas inútiles llamadas .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

Las llamadas consecutivas .Select significan que todas, excepto la última, tienen un propósito, si corresponde:

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

Nuevamente, no asigne ActiveCell cuando pueda asignar .Range("A7").Value directamente.

Y puede establecer formatos de números para un rango de celdas:

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