VBA：用于英国银行假日的嵌套JSON对象结构-运行时错误13、438和449

我希望从导入所有英格兰和威尔士的银行假日，并使用MS Access VBA模块将其添加到预先创建的MS Access记录集（称为“TestTable”）。下面的代码打开json并将其转换为字符串，然后使用JsonConverter对其进行解析

这似乎是我遇到麻烦的地方——我似乎无法获得字典和集合的正确组合来告诉VBA模块json文件的结构（我在Access中创建记录没有问题）。解析json之后，我得到了两个错误中的一个，很可能是因为我认为应该是一个字典（带{}括号）和应该是一个集合（带[]括号）的内容给了我错误

Option Explicit
Sub ImportBH()

    Dim Parsed As Dictionary
    Dim rsT As DAO.Recordset
    Dim jsonStr As String
    Dim dictionaryKey, var1 As Variant
    Dim initialCollection As Collection
    Set rsT = CurrentDb.OpenRecordset("TestTable")
    Dim httpobject As Object
    Set httpobject = CreateObject("MSXML2.XMLHTTP")
    httpobject.Open "GET", "https://www.gov.uk/bank-holidays.json", False
    httpobject.Send
    jsonStr = httpobject.responsetext
    Set Parsed = ParseJson(jsonStr) 'parse json data

如果我现在使用该行：

For Each dictionaryKey In Parsed("england-and-wales")

For Each dictionaryKey In Parsed.Keys

然后在JsonConverter中“item”函数的末尾，我得到一个运行时错误438：对象不支持此属性或方法

另一方面，如果我使用该行：

For Each dictionaryKey In Parsed("england-and-wales")

For Each dictionaryKey In Parsed.Keys

然后它工作（使用JsonConverter中的“Keys”函数），当我将鼠标悬停在“Parsed.Keys”上时，它会给我“england and wales”。然而，在下面代码的第一行，我得到了一个运行时错误13：类型不匹配

        Set initialCollection = dictionaryKey("events")
        With rsT
            .AddNew
            ![Title] = var1("title")
            ![Datex] = var1("date")
            ![Notes] = var1("notes")
            .Update
        End With
    Next
End Sub

我在这些链接中尝试了解决方案（以及其他类似的）

-我知道这是为了导出json而不是导入，但我认为语法可能会有所帮助，正如Tim Hall自己回答的那样。很遗憾，“.Data”属性不显示或不适用于我：(

-当尝试将此应用于英国银行假日json时，我再次遇到运行时错误13

-如果我尝试，例如：

Debug.Print Parsed(dictionaryKey)

在JsonConverter中的“item”函数之后，我得到一个运行时错误449：参数不是可选的

-我无法进入创建集合的阶段，以使用“.Count”来完成此工作

---

如果有人曾经在VBA中实现过这一点，或者能够提供帮助，那将非常感谢！

从学习如何读取json结构开始。您可以将json字符串粘贴到中。然后您可以很好地查看该结构。在VBA json中，[]表示可以通过索引访问的集合，{}表示您可以为每个键或通过特定键访问的字典

如果将json放入查看器中，您应该阅读如下内容：

---

用作模板的Excel版本： 访问所有项目：

下面展示了一种将整个json清空到数组中的方法（您可以修改添加到记录集？）

---

访问OP附加的版本： 除了上面的TransportSearray（在本例中编辑如下），以下是访问的完整代码：

Option Compare Database
Option Explicit
Public Sub UpdateBankHolidays()
    Dim dbs As DAO.Database
    Dim tBH As Recordset
    Dim i, r, c As Long
    Set dbs = CurrentDb
    'Set recordset variable as existing table (in this case, called "z_BankHolidays")
    Set tBH = dbs.OpenRecordset("z_BankHolidays")

    'Download and parse json
    Dim json As Object, results(), counter As Long
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.gov.uk/bank-holidays.json", False
        .Send
        Set json = ParseJson(.responsetext)      'dictionary with 3 keys
    End With

    Dim key As Variant, innerKey As Variant, col As Collection
    Dim division As String, headers(), item As Object, arr()
    arr = json.Keys
    headers = json(arr(LBound(arr)))("events").item(1).Keys 'take first innermost dictionary keys as headers for output

    'oversize array as number of events can vary by division
    ReDim results(1 To 1000, 1 To UBound(headers) + 2) '4 is the number of keys for each event level dictionary. +1 so can have _
                                                       division included as first column in output and +1 to move from 0 based headers array to 1 based results

    r = 1                                        'leave first row for headers
    results(1, 1) = "Division"
    For c = LBound(headers) To UBound(headers)
        results(1, c + 2) = headers(c)           'write out rest of headers to first row
    Next
    For Each key In json.Keys                    'england-and-wales etc. division
        division = key
        For Each item In json(division)("events") 'variable number of events dictionaries within collection
            r = r + 1: c = 2                     'create a new row for event output. Set column to 2 (as position 1 will be occupied by division
            results(r, 1) = division
            For Each innerKey In item.Keys       'write out innermost dictionary values into row of array
                results(r, c) = item(innerKey)
                c = c + 1
            Next
        Next
    Next
    'transpose array so can redim preserve the number of rows (now number of columns) to only required number based on current value of r
    results = TransposeArray(results)
    ReDim Preserve results(0 To UBound(results), 0 To r)
    results = TransposeArray(results)            'transpose array back

    'Clear all existing bank holidays from recordset
    dbs.Execute "DELETE * FROM " & tBH.Name & ";"

    'Insert array results into tBH recordset, transforming the date into a date value using a dd/mmm/yyyy format (in the array they are currently yyyy-mm-dd)
    For i = 1 To r
        If results(i, 1) = "england-and-wales" Then
            dbs.Execute " INSERT INTO " & tBH.Name & " " _
                      & "(Title,Holiday,Notes) VALUES " _
                      & "('" & results(i, 2) & "', " & _
                        "'" & DateValue(Right(results(i, 3), 2) & "/" & Format("20/" & Mid(results(i, 3), 6, 2) & "/2000", "mmm") & "/" & Left(results(i, 3), 4)) & "', " & _
                        "'" & results(i, 4) & "'" & _
                        ");"
        End If
    Next

    'Finish
    MsgBox "Bank Holidays updated."

End Sub

还值得注意的是，我（OP）必须将TransposeArray中的X和Y更改为从1开始，而不是从0开始（尽管如上所述和在注释中，随后重新命名它必须以0为基础）。即：

---

忘了提到引用-我已经启用了Microsoft DAO 3.6对象库和Microsoft脚本运行时表示数组，而不是

集合

。我发布了一个小的JSON库，可能会有所帮助。如果解析JSON时遇到问题，请共享JSON。谢谢@QHarr！在MS Access中，Application.Transpose不存在，所以我使用例如手动转置。另外，我还收到了一个“运行时错误9：下标超出范围”在

ReDim Preserve results（1到UBound（headers）+2，1到r）

，即使

（lbound（results，1）

和

lbound（results，2）

给出了1，将行更改为

（ReDim Preserve results（0到UBound（headers）+2，0到r）

成功了！括号是一个输入错误。尽管

lbound（结果，1）

和

lbound（结果，2）

都返回1，将行更改为

ReDim Preserve results（0到UBound（标题））+2，0到r

成功了！再次感谢。注意：是的，是我，拿着烛台，在图书馆。你介意编辑我的答案，将最终的Access版本包含在底部吗？这对未来的读者更有用。完成。再次感谢，带注释的图片特别有用。

Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(Xupper, Yupper)
For X = 1 To Xupper
    For Y = 1 To Yupper
        tempArray(X, Y) = myarray(Y, X)
    Next Y
Next X
TransposeArray = tempArray
End Function