使用VBA将JSON解析为Excel

Question

我在 VBA 中解析 JSON 数据时遇到一些问题。我已经尝试了网上的所有示例，但仍然无法解决问题。我设法做的是使用另一个从另一个网站提取数据的 VBA 代码将 JSON 数据以原始格式提取到 Excel 中。我粘贴了下面有效的代码。它不是很干净，而且有一些重复，因为我只是想看看是否可以提取数据。 我尝试使用 VBA 解析数据的所有尝试都失败了，并出现了各种错误，具体取决于我采取的方法。如果有人能给我一些关于解析我设法提取的数据的最简单方法的建议，我将非常感激。我所需要的只是列中的数据，然后我可以在工作簿的其他工作表中使用这些数据。我附上了我提取的数据的图片。我已经成功地从另一个网页解析 JSON 数据，并且在代码中包含了 JSON 数据的每个列标题。对于这个新网页，JSON 数据是嵌套的，并且有大量独特的行，因此我没有采用这种方法。非常感谢

[Sub JSONPull()
Dim WB As Workbook, ws As Worksheet, ws2 As Worksheet, qtb As QueryTable
Dim FC As String, sDate As String, eDate As String, Dockmasterurl As String, Performance As Worksheet

Set WB = Application.ThisWorkbook
Set ws = WB.Sheets("Control")

FC = ws.Range("B5")
sDate = ws.Range("B14")
eDate = ws.Range("B15")
Dim sJSONString As String
    Dim vJSON
    Dim sState As String
    Dim aData()
    Dim aHeader()
    Dim vResult

Dockmasterurl = "https://fc-inbound-dock-execution-service-eu-eug1-dub.dub.proxy.amazon.com/appointment/bySearchParams?warehouseId=" & FC & "&clientId=dockmaster&localStartDate=" & sDate & "T00%3A00%3A00&localEndDate=" & eDate & "T08%3A00%3A00&isStartInRange=false&searchResultLevel=FULL"

Set ws2 = Sheets("JSON")
ws2.Cells.ClearContents

Set qtb = ws2.QueryTables.Add("URL;" & Dockmasterurl, ws2.Range("A1"))
With qtb
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = True
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

ws2.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, textqualifier:=xlDoubleQuote, consecutivedelimiter:=False, comma:=True, trailingminusnumbers:=True
ws2.Range("A:S").EntireColumn.AutoFit

For Each qtb In ws2.QueryTables
    qtb.Delete

Next

End Sub][1]

Answer 1

这里是 VBA 示例，展示了如何将链接中的 JSON 示例转换为 2D 数组并输出到工作表。 将JSON.bas模块导入到VBA项目中进行JSON处理。

Option Explicit

Sub Test()

    Dim sJSONString As String
    Dim vJSON
    Dim sState As String
    Dim aData()
    Dim aHeader()

    ' Retrieve JSON content
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://pastebin.com/raw/hA2UEDXy", True
        .send
        Do Until .readyState = 4: DoEvents: Loop
        sJSONString = .responseText
    End With
    ' Parse JSON sample
    JSON.Parse sJSONString, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    ' Convert JSON to 2D Array
    JSON.ToArray vJSON("AppointmentList"), aData, aHeader
    ' Output to worksheet #1
    Output aHeader, aData, ThisWorkbook.Sheets(1)
    MsgBox "Completed"

End Sub

Sub Output(aHeader, aData, oDestWorksheet As Worksheet)

    With oDestWorksheet
        .Activate
        .Cells.Delete
        With .Cells(1, 1)
            .Resize(1, UBound(aHeader) - LBound(aHeader) + 1).Value = aHeader
            .Offset(1, 0).Resize( _
                    UBound(aData, 1) - LBound(aData, 1) + 1, _
                    UBound(aData, 2) - LBound(aData, 2) + 1 _
                ).Value = aData
        End With
        .Columns.AutoFit
    End With

End Sub

我的输出如下（点击放大）：

顺便说一句，类似的方法适用于

其他答案。

Answer 2

Sub JSONtoCSV()
Dim JsonText As String
Dim JsonObject As Object
Dim FSO As Object
Dim JsonFile As Object
Dim key As Variant
Dim item As Object
Dim row As Long
Dim col As Long
Dim headers As New Collection
Dim header As Variant
Dim ws As Worksheet

' Set the worksheet where data will be written
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name

' Read JSON file
Set FSO = CreateObject("Scripting.FileSystemObject")
Set JsonFile = FSO.OpenTextFile("C:\path\to\your\file.json", 1) ' 1 = ForReading
JsonText = JsonFile.ReadAll
JsonFile.Close

' Parse JSON
Set JsonObject = JsonConverter.ParseJson(JsonText)

' Initialize row and column counters
row = 1
col = 1

' Get headers from the first JSON object
For Each item In JsonObject
    For Each key In item.Keys
        On Error Resume Next
        headers.Add key, key
        On Error GoTo 0
    Next key
Next item

' Write headers to Excel sheet
For Each header In headers
    ws.Cells(row, col).Value = header
    col = col + 1
Next header

' Reset column counter and increment row counter
col = 1
row = row + 1

' Write data to Excel sheet
For Each item In JsonObject
    For Each header In headers
        If item.Exists(header) Then
            ws.Cells(row, col).Value = item(header)
        Else
            ws.Cells(row, col).Value = ""
        End If
        col = col + 1
    Next header
    col = 1
    row = row + 1
Next item

' Autofit columns for better visibility
ws.Columns.AutoFit

MsgBox "JSON data has been imported to Excel."

结束子