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%"