Получить заголовки таблицы при использовании подхода XMLHTTP

Question

У меня есть код, который захватывает таблицу с этого URL

https://www.reuters.com/companies/AAPL.OQ/financials/income-statement-annual

Код в порядке, и никаких проблем нет кроме одного пункта. Код получает таблицу, но не получает заголовок

    With http
    .Open "Get", sURL, False
    .send
    html.body.innerHTML = .responseText
End With

   Set tbl = html.getElementsByTagName("Table")(0)

        For Each rw In tbl.Rows
            r = r + 1: c = 1
            For Each cl In rw.Cells
                ws.Cells(r, c).Value = cl.innerText
                c = c + 1
            Next cl
    Next rw

При проверке URL-адреса я обнаружил, что поддерживаемый URL-адрес API

https://www.reuters.com/companies/api/getFetchCompanyFinancials/AAPL.OQ

Как я могу извлечь желаемые данные "годовой" для "дохода" из ответа JSON?

Я пытался обратиться к желаемому разделу, но получил ошибку

Const strUrl As String = "https://www.reuters.com/companies/api/getFetchCompanyFinancials/AAPL.OQ"

Sub Test()
Dim a, json As Object, colData As Collection, sFile As String, i As Long

With CreateObject("MSXML2.ServerXMLHTTP.6.0")
    .Open "GET", strUrl
    .send
    Set json = JSONConverter.ParseJson(.responseText)
End With


Set colData = json("market_data")("financial_statements")

Stop
End Sub

Answer 1

После стольких часов я мог бы настроить его так

Const strUrl As String = "https://www.reuters.com/companies/api/getFetchCompanyFinancials/"

Sub GetData()
    Dim ws As Worksheet, sSection As String

    For Each ws In ThisWorkbook.Worksheets(Array("IS", "BS", "CF"))
        Select Case ws.Name
            Case "IS": sSection = "income"
            Case "BS": sSection = "balance_sheet"
            Case "CF": sSection = "cash_flow"
        End Select

        GetReuters ws, "tbl" & ws.Name, Sheets("Data").Range("B1").Value, sSection, Sheets("Data").Range("B2").Value
    Next ws
End Sub

Sub GetReuters(ByVal ws As Worksheet, ByVal tblName As String, ByVal sTicker As String, ByVal sSection As String, ByVal sTime As String)
    Dim a, ky, col As Collection, json As Object, data As Object, dic As Object, rng As Range, i As Long, k As Long, c As Long

    With CreateObject("MSXML2.ServerXMLHTTP.6.0")
        .Open "GET", strUrl & sTicker
        .send
        Set json = JSONConverter.ParseJson(.responseText)
    End With

    ReDim b(1 To 10000, 1 To 7)
    c = 1: b(1, c) = "Dates"

    Set data = json("market_data")("financial_statements")(sSection)(sTime)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1

    For Each ky In data.Keys
        Set col = data(ky)
        a = CollectionToArray(col)
        k = k + 1
        b(k + 1, 1) = ky

        For i = LBound(a) To UBound(a)
            If Not dic.Exists(CStr(a(i, 1))) Then
                dic(CStr(a(i, 1))) = c
                c = c + 1

                b(1, c) = CStr(a(i, 1))
                b(k + 1, c) = a(i, 2)

            Else
                b(k + 1, dic.item(CStr(a(i, 1))) + 1) = a(i, 2)
            End If
        Next i

        Erase a
    Next ky

    Application.ScreenUpdating = False
        With ws
            On Error Resume Next
                .ListObjects(tblName).Delete
            On Error GoTo 0
            .Range("A1").Resize(k + 1, UBound(b, 2)).Value = b
            With .Range("A1").CurrentRegion
                Set rng = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                rng.NumberFormat = "#,##0.00;(#,##0.00)"
                rng.Rows(1).Offset(-1).NumberFormat = "dd-mmm-yy"
                .Columns.AutoFit
            End With

            .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Name = tblName
        End With
    Application.ScreenUpdating = True
End Sub

Function CollectionToArray(ByVal c As Collection) As Variant()
    Dim a(), i As Long
    ReDim a(1 To c.Count, 1 To 2)

    For i = 1 To c.Count
        a(i, 1) = c.item(i)("date")
        a(i, 2) = c.item(i)("value")
    Next i

    CollectionToArray = a
End Function

Answer 2

logi c аналогично этому должно работать в vba:

Dim data As Scripting.Dictionary, key As Variant, block As Collection, r As Long, item As Object

Set data = json("market_data")("financial_statements")("financial_statements")("income")("annual") ' dict of collections

r = 1

For Each key In data.keys
    Set block = data(key)  'each block (section of info) is a row
    r = r + 1: c= 2
    For each item In block 'loop columns in block         
        With Activesheet
            If r = 2 then 'write out headers to row 1,starting col2 and then values to row 2 starting from col 2, and key goes in row , col 1
                .Cells(1,c) = item("date")
            End If
            .Cells(r,1) = Key
            .Cells(r,c) = item("value")
        End With
        c = c + 1
    Next
Next

Я не могу тестировать в VBA, но если я пишу эквивалент python (длинная рука), я получаю ту же таблицу:

import requests
import pandas as pd

json = requests.get('https://www.reuters.com/companies/api/getFetchCompanyFinancials/AAPL.OQ').json()
data = json["market_data"]["financial_statements"]["income"]["annual"]
rows = len(data.keys()) + 1
columns = len(data["Revenue"]) + 1
r = 0
df = pd.DataFrame(["" for c in range(columns)] for r in range(rows))

for key in data.keys():
    block = data[key]
    r+=1 ; c = 1
    for item in block:
        if r == 1:
            df.iloc[0 , c] = item["date"]
        df.iloc[r,c] = item["value"]
        df.iloc[r,0] = key
        c+=1
print(df)