无法使用 WebHelpers 从 json 填充 excel 电子表格

Question

我在使用 VBA 使用 WebHelpers 从 JSON 填充表格时遇到问题。 JSON 可在此处访问：http://54.152.85.66:5000/get-product-info。该表非常简单，只有六列和大约 8k 行。

代码如下：

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-problems”）之外，此解决方案效果很好，但似乎可以从架构中提取标头而不是硬编码，并且对于对于 helperData 循环中的每个项目。这将使解决方案更简洁、更通用。

Answer 1

我使用的是不同的json parser，但这会破坏字典和集合。如果将 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