Не удается заполнить таблицу Excel из json с помощью WebHelpers

Question

У меня проблемы с использованием VBA для заполнения таблицы из JSON с помощью WebHelpers. Доступ к JSON можно получить здесь: http://54.152.85.66:5000/get-product-info. Таблица очень простая, всего шесть столбцов и около 8 тыс. Строк.

Вот код:

Sub LoadRLSiteData()
Dim helperData As Object
Dim helperDict As Dictionary
Set helperData = 
WebHelpers.ParseJson(getXMLPage("http://54.152.85.66:5000/get-product-info"))
Debug.Print "helperData has " & helperData.Count & " items"
' HERE YOU SHOULD LOOP OVER helperData AND PUT INTO SHEET "Helper"
End Sub

Function getXMLPage(link) As String
On Error GoTo recovery
Dim retryCount As Integer
retryCount = 0
Dim ie As MSXML2.XMLHTTP60
Set ie = New MSXML2.XMLHTTP60
the_start:
ie.Open "GET", link, False
ie.setRequestHeader "Content-type", "application/json"
ie.send

While ie.readyState <> 4
    DoEvents
Wend

Debug.Print " "
Debug.Print "MSXML HTTP Request to " & link
Debug.Print ie.Status; "XMLHTTP status "; ie.statusText; " at "; Time
getXMLPage = ie.responseText
Exit Function
recovery:
retryCount = retryCount + 1
Debug.Print "Error number: " & Err.Number _
        & " " & Err.Description & " Retry " & retryCount
        Application.StatusBar = "Error number: " & Err.Number _
        & " " & Err.Description & " Retry " & retryCount

If retryCount < 4 Then GoTo the_start Else Exit Function
End Function

Вот как должна выглядеть таблица:

WebHelpers.ParseJson (getXMLPage ("http://54.152.85.66:5000/get-product-info")) возвращает объект, который выглядит как набор из девяти словарей, но я не могу понять, как получить доступ к элементам в словаре, чтобы я мог поместить их в лист.

Я изменил код, основываясь на ответе QHarr, следующим образом:

Option Explicit
Sub LoadRLSiteData()
Dim newHeaders() As Variant
newHeaders = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
GetInfo "Helper Sample", "http://54.152.85.66:5000/get-product-info", newHeaders
newHeaders = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
GetInfo "Images Sample", "http://54.152.85.66:5000/query-missing-images", newHeaders
newHeaders = Array("category", "problem", "url")
GetInfo "Problems Sample", "http://54.152.85.66:5000/get-problems", newHeaders
End Sub
Public Sub GetInfo(mySheet As String, link As String, myHeaders As Variant)
Dim helperData As Object
Dim headers(), item As Object, results(), key As Variant
Dim subItem As Object, r As Long, c As Long, cat As String
Worksheets(mySheet).Activate
Set helperData = WebHelpers.ParseJson(getXMLPage(link))
headers = myHeaders
ReDim results(1 To 100000, 1 To UBound(headers) + 1)
r = 1
Debug.Print "GetInfo unpacking JSON dictionaries"
For Each item In helperData                  'col of dict
    DoEvents
    cat = item("category")
    For Each subItem In item("products")
        c = 2
        results(r, 1) = cat
        For Each key In subItem.Keys
            results(r, c) = subItem(key)
            c = c + 1
        Next
        r = r + 1
    Next
Next
Debug.Print "GetInfo loading values to worksheet"
ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
Debug.Print "GetInfo finished"
End Sub
Function getXMLPage(link) As String
On Error GoTo recovery
Dim retryCount As Integer
retryCount = 0
Dim ie As MSXML2.XMLHTTP60
Set ie = New MSXML2.XMLHTTP60
the_start:
ie.Open "GET", link, False
ie.setRequestHeader "Content-type", "application/json"
ie.send

While ie.readyState <> 4
    DoEvents
Wend

Debug.Print " "
Debug.Print "MSXML HTTP Request to " & link
Debug.Print ie.Status; "XMLHTTP status "; ie.statusText; " at "; Time
getXMLPage = ie.responseText
Exit Function
recovery:
retryCount = retryCount + 1
Debug.Print "Error number: " & Err.Number _
        & " " & Err.Description & " Retry " & retryCount
        Application.StatusBar = "Error number: " & Err.Number _
        & " " & Err.Description & " Retry " & retryCount

If retryCount < 4 Then GoTo the_start Else Exit Function

End Function

За исключением третьего URL-адреса ("get-problem"), который имеет другую схему, это решение прекрасно работает, но кажется, что заголовки можно извлечь из схемы вместо жесткого кодирования и то же самое для переменных в Для каждого элемента в цикле helperData. Это сделало бы решение более чистым и более обобщенным.

Answer 1

Я использую другой json парсер , но это распутывает словари и коллекции.Если вы устанавливаете код из jsonconverter.bas в свой проект, перейдите в VBE> Инструменты> Ссылки> Добавить ссылку на Microsoft Scripting Runtime.Вы можете увидеть, как использовать снизу сначала End With

. [] - это коллекции, зацикленные с For Each и доступные по индексу;{} являются словарями, доступ к которым осуществляется по ключу.

Некоторые структуры можно увидеть здесь:

---

VBA:

Option Explicit   
Public Sub GetInfo()
    Dim helperData As Object
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://54.152.85.66:5000/get-product-info", False
        .send
        Set helperData = jsonConverter.ParseJson(.responseText)
    End With
    Dim headers(), item As Object, results(), key As Variant
    Dim subItem As Object, r As Long, c As Long, cat As String
    headers = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
    ReDim results(1 To 100000, 1 To UBound(headers) + 1)
    r = 1
    For Each item In helperData                        'col of dict
        cat = item("category")
        For Each subItem In item("products")
            c = 2
            results(r, 1) = cat
            For Each key In subItem.keys
                results(r, c) = subItem(key)
                c = c + 1
            Next
            r = r + 1
        Next
    Next
    ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
    ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub

---

Пример вывода:

---

Интеграция с вашим Я бы ожидал что-то вроде:

Option Explicit
Public Sub GetInfo()
    Dim helperData As Object
    Dim headers(), item As Object, results(), key As Variant
    Dim subItem As Object, r As Long, c As Long, cat As String
    Set helperData = WebHelpers.ParseJson(getXMLPage("http://54.152.85.66:5000/get-product-info"))
    headers = Array("category", "products_category", "products_master_prod_id", "products_page_name_dub", "products_product_webcat", "products_url")
    ReDim results(1 To 100000, 1 To UBound(headers) + 1)
    r = 1
    For Each item In helperData                  'col of dict
        cat = item("category")
        For Each subItem In item("products")
            c = 2
            results(r, 1) = cat
            For Each key In subItem.keys
                results(r, c) = subItem(key)
                c = c + 1
            Next
            r = r + 1
        Next
    Next
    ActiveSheet.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
    ActiveSheet.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub