使用VBA JsonConverter处理多结果JSON报错，求Access批量入库方案

嘿，我之前也踩过这个坑！问题根源很明确：JSON规范本身不允许对象存在重复键，而你用的VBA-JSON的JsonConverter.ParseJson方法是把JSON对象转成VBA的Dictionary——但Dictionary的键是唯一的，所以遇到重复的"imei"字段时直接就触发报错了。

要解决这个问题，我们需要先预处理返回的ResponseText，把重复的键值对合并成数组形式，这样ParseJson就能正常解析，之后再遍历数组把数据插入Access的多行里。

第一步：预处理JSON文本，合并重复键为数组 #

写一个VBA函数来修复重复的JSON键，把重复键对应的多个值打包成数组：

Function FixDuplicateJsonKeys(jsonText As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.MultiLine = True
    
    ' 先匹配并收集所有重复键的对应值
    regex.Pattern = "\""([^""]+)\"":\s*\""([^""]+)\"",?\s*(?=\""\1\"":)"
    Dim matches As Object
    Set matches = regex.Execute(jsonText)
    
    Dim keyValueMap As Object
    Set keyValueMap = CreateObject("Scripting.Dictionary")
    
    Dim match As Object
    For Each match In matches
        Dim targetKey As String
        targetKey = match.SubMatches(0)
        Dim targetValue As String
        targetValue = match.SubMatches(1)
        
        If keyValueMap.Exists(targetKey) Then
            keyValueMap(targetKey) = keyValueMap(targetKey) & ",""" & targetValue & """"
        Else
            keyValueMap(targetKey) = """" & targetValue & """"
        End If
    Next match
    
    ' 将重复的键值对替换为数组格式
    For Each targetKey In keyValueMap.Keys
        Dim replacePattern As String
        replacePattern = "(\""" & targetKey & "\"":\s*\""[^""]+\"",?\s*)+\""" & targetKey & "\"":\s*\""([^""]+)\"""
        regex.Pattern = replacePattern
        jsonText = regex.Replace(jsonText, """$0"":[" & keyValueMap(targetKey) & ",""$2""]")
    Next targetKey
    
    ' 清理数组末尾可能多余的逗号
    regex.Pattern = ",\s*]"
    jsonText = regex.Replace(jsonText, "]")
    
    FixDuplicateJsonKeys = jsonText
End Function

第二步：解析处理后的JSON并导入Access #

修改你原来的代码，先预处理JSON文本，再解析，最后把数组里的每条数据插入Access：

Sub ProcessJsonAndImportToAccess()
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP.6.0")
    
    ' 这里省略你的GET请求逻辑，假设已经获取到ResponseText
    ' xmlhttp.Open "GET", "你的接口URL", False
    ' xmlhttp.Send
    ' ...
    
    ' 预处理JSON文本，修复重复键
    Dim cleanedJson As String
    cleanedJson = FixDuplicateJsonKeys(xmlhttp.ResponseText)
    
    ' 解析JSON
    Dim Json As Object
    Set Json = JsonConverter.ParseJson(cleanedJson)
    
    ' 连接Access数据库并插入数据
    Dim accDb As Object
    Set accDb = CreateObject("Access.Application")
    accDb.OpenCurrentDatabase "C:\Path\To\Your\Database.accdb" '替换为你的数据库路径
    
    ' 安全插入数据（用Recordset避免SQL注入）
    Dim rs As Object
    Set rs = accDb.CurrentDb.OpenRecordset("YourTableName", 2) 'dbOpenDynaset = 2
    
    Dim imeiItem As Variant
    For Each imeiItem In Json("imei")
        rs.AddNew
        rs("IMEI") = imeiItem '替换为你的表字段名
        rs.Update
    Next imeiItem
    
    ' 清理资源
    rs.Close
    accDb.CloseCurrentDatabase
    Set rs = Nothing
    Set accDb = Nothing
    Set Json = Nothing
    Set xmlhttp = Nothing
    
    MsgBox "数据导入完成！"
End Sub

关键说明 #

1. 为什么要预处理？：不符合规范的重复键会让ParseJson直接崩溃，把重复键转成数组后，JSON就符合标准规范了，ParseJson会把它解析成一个可遍历的数组对象。
2. 安全插入的必要性：用Recordset的AddNew/Update方式比直接拼接SQL语句更安全，能避免单引号等特殊字符导致的SQL语法错误，也能防范SQL注入风险。

内容的提问来源于stack exchange，提问作者Gregory