求通用VBA子程序：将扁平化JSON导入Access数据库表

需求说明 #

我使用omegastripes开发的VBA-JSON-parser库将JSON文件导入Access数据库，现有方案需要提前明确字段名，灵活性不足。需要实现一个通用Sub过程，满足以下要求：

• 支持将任意扁平化JSON对象导入Access表
• 目标表不存在时自动创建
• 可指定忽略不需要的字段（如嵌套数组、无关元数据）
• 后续可手动建立表关系

示例JSON数据（仅需导入contacts数组中的扁平化字段，忽略meta和phones）：

{
  "contacts": [
    {
      "id": 9785,
      "type": "Individual",
      "first_name": "John",
      "middle_name": "Jacob",
      "last_name": "Jingleheimer-Schmidt",
      "suffix": "Sr.",
      "company_name": null,
      "added_by": 337864,
      "phones": [
        {
          "id": 204,
          "number": "8884447777"
        }
      ]
    },
    {
      "id": 9887,
      "type": "Individual",
      "first_name": "John",
      "middle_name": "Jacob",
      "last_name": "Jingleheimer-Schmidt",
      "suffix": "Jr.",
      "company_name": null,
      "added_by": 337864,
      "phones": []
    },
    {
      "id": 8556,
      "type": "Business",
      "first_name": null,
      "middle_name": null,
      "last_name": null,
      "company_name": "J&J Construction",
      "added_by": null,
      "phones": [
        {
          "id": 13168,
          "number": "5557779999"
        },
        {
          "id": 13169,
          "number": "2224446666"
        }
      ]
    }
  ],
  "meta": {
    "total_records": 3,
    "total_pages": 1
  }
}

解决方案代码 #

Sub ImportFlatJSONToAccess(jsonFilePath As String, targetTableName As String, topLevelArrayKey As String, Optional ignoreFields As Variant)
    Dim jsonText As String
    Dim jsonObj As Object
    Dim records As Collection
    Dim record As Object
    Dim fields As Collection
    Dim fieldName As String
    Dim fieldType As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim createTableSQL As String
    Dim i As Integer
    Dim isIgnored As Boolean
    
    ' 处理忽略字段参数默认值
    If IsMissing(ignoreFields) Then
        Set ignoreFields = New Collection
    ElseIf IsArray(ignoreFields) Then
        Dim tempCol As New Collection
        For Each item In ignoreFields
            tempCol.Add item
        Next
        Set ignoreFields = tempCol
    End If
    
    ' 读取JSON文件内容
    Open jsonFilePath For Input As #1
    jsonText = Input$(LOF(1), 1)
    Close #1
    
    ' 解析JSON
    Set jsonObj = JsonConverter.ParseJson(jsonText)
    Set records = jsonObj(topLevelArrayKey)
    
    ' 收集所有需要的字段及类型
    Set fields = New Collection
    For Each record In records
        For Each fieldName In record
            ' 检查是否在忽略列表中
            isIgnored = False
            For i = 1 To ignoreFields.Count
                If ignoreFields(i) = fieldName Then
                    isIgnored = True
                    Exit For
                End If
            Next
            If isIgnored Then GoTo NextField
            
            ' 判断字段类型（仅处理扁平化数据，跳过嵌套对象/数组）
            Select Case TypeName(record(fieldName))
                Case "Integer", "Long", "Double"
                    fieldType = "LONG"
                Case "String"
                    fieldType = "TEXT(255)"
                Case "Null"
                    ' 若字段为Null，先默认设为TEXT，后续遇到非Null值再调整
                    On Error Resume Next
                    fields(fieldName)
                    If Err.Number <> 0 Then
                        fields.Add "TEXT(255)", Key:=fieldName
                    End If
                    On Error GoTo 0
                    GoTo NextField
                Case Else
                    ' 跳过嵌套对象或数组
                    isIgnored = True
            End Select
            
            ' 更新字段类型（确保兼容所有记录）
            On Error Resume Next
            Dim existingType As String
            existingType = fields(fieldName)
            If Err.Number = 0 Then
                ' 若已有字段类型为TEXT，遇到数字类型则保留TEXT（避免数据截断）
                If existingType <> "TEXT(255)" And fieldType = "TEXT(255)" Then
                    fields.Remove fieldName
                    fields.Add fieldType, Key:=fieldName
                End If
            Else
                fields.Add fieldType, Key:=fieldName
            End If
            On Error GoTo 0
            
NextField:
        Next
    Next
    
    ' 创建或打开目标表
    Set db = CurrentDb()
    On Error Resume Next
    db.TableDefs(targetTableName)
    If Err.Number <> 0 Then
        ' 表不存在，生成创建表SQL
        createTableSQL = "CREATE TABLE " & targetTableName & " ("
        For i = 1 To fields.Count
            createTableSQL = createTableSQL & fields.Keys(i) & " " & fields(i)
            If i < fields.Count Then createTableSQL = createTableSQL & ", "
        Next
        createTableSQL = createTableSQL & ")"
        db.Execute createTableSQL
    End If
    On Error GoTo 0
    
    ' 插入数据
    Set rs = db.OpenRecordset(targetTableName, dbOpenDynaset)
    For Each record In records
        rs.AddNew
        For Each fieldName In record
            ' 跳过忽略字段和嵌套数据
            isIgnored = False
            For i = 1 To ignoreFields.Count
                If ignoreFields(i) = fieldName Then
                    isIgnored = True
                    Exit For
                End If
            Next
            If isIgnored Then GoTo NextRecordField
            If TypeName(record(fieldName)) = "Collection" Or TypeName(record(fieldName)) = "Dictionary" Then
                GoTo NextRecordField
            End If
            
            ' 写入字段值
            If Not IsNull(record(fieldName)) Then
                rs(fieldName) = record(fieldName)
            End If
NextRecordField:
        Next
        rs.Update
    Next
    
    ' 清理对象
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set records = Nothing
    Set jsonObj = Nothing
    MsgBox "导入完成，共导入 " & records.Count & " 条记录", vbInformation
End Sub

代码说明 #

1. 参数说明：

   • jsonFilePath：JSON文件的完整路径
   • targetTableName：Access中目标表的名称
   • topLevelArrayKey：JSON中需要导入的顶级数组键（如示例中的contacts）
   • ignoreFields：可选参数，指定需要忽略的字段名（支持数组或Collection）

2. 核心逻辑：

   • 读取并解析JSON文件，提取目标数组
   • 遍历数组收集所有非忽略、非嵌套的字段，并自动判断字段类型（优先兼容所有记录）
   • 自动创建不存在的表，字段类型匹配JSON数据
   • 批量插入数据，跳过忽略字段和嵌套结构

3. 类型兼容处理：

   • 数字类型映射为Access的LONG
   • 字符串类型映射为TEXT(255)
   • 若字段存在Null值或混合类型，统一使用TEXT(255)避免数据丢失

示例调用 #

' 导入contacts数组，忽略phones字段
ImportFlatJSONToAccess "C:\Data\contacts.json", "tbl_Contacts", "contacts", Array("phones")

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