将第三方XML数据导入Microsoft Access表的VBA实现需求

需求概述 #

• 第三方提供的是Excel格式XML文件，打开后有3个工作表，仅需提取MetaInfo和CustomInfo的数据
• Access内置XML导入功能会把表头当成记录行，格式错误
• 需要通过窗体按钮触发VBA，让用户自行选择本地下载的XML文件，自动导入到对应Access表

完整VBA代码 #

把以下代码绑定到窗体按钮的Click事件中：

Private Sub cmdImportXML_Click()
    Dim fd As FileDialog
    Dim xmlPath As String
    Dim xmlDoc As MSXML2.DOMDocument60
    Dim nsManager As MSXML2.IXMLDOMNamespaceManager
    Dim wsNode As MSXML2.IXMLDOMNode
    Dim tableNode As MSXML2.IXMLDOMNode
    Dim rowNodes As MSXML2.IXMLDOMNodeList
    Dim rowNode As MSXML2.IXMLDOMNode
    Dim cellNodes As MSXML2.IXMLDOMNodeList
    Dim cellNode As MSXML2.IXMLDOMNode
    Dim headers As Variant
    Dim dataRow As Variant
    Dim tblName As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim i As Integer, j As Integer
    
    ' 让用户选择XML文件
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "XML文件", "*.xml"
        .Title = "选择要导入的XML文件"
        If .Show <> -1 Then Exit Sub
        xmlPath = .SelectedItems(1)
    End With
    Set fd = Nothing
    
    ' 加载XML文档并设置命名空间
    Set xmlDoc = New MSXML2.DOMDocument60
    xmlDoc.async = False
    xmlDoc.validateOnParse = False
    If Not xmlDoc.Load(xmlPath) Then
        MsgBox "XML文件加载失败：" & xmlDoc.parseError.reason, vbCritical
        Exit Sub
    End If
    
    ' 设置命名空间管理器（XML里的spreadsheet命名空间）
    Set nsManager = xmlDoc.createNamespaceManager(xmlDoc.documentElement)
    nsManager.AddNamespace "ss", "urn:schemas-microsoft-com:office:spreadsheet"
    
    ' 处理MetaInfo工作表
    tblName = "MetaInfo"
    Set wsNode = xmlDoc.SelectSingleNode("//ss:Worksheet[@ss:Name='" & tblName & "']", nsManager)
    If Not wsNode Is Nothing Then
        Set tableNode = wsNode.SelectSingleNode("ss:Table", nsManager)
        Set rowNodes = tableNode.SelectNodes("ss:Row", nsManager)
        
        ' 获取表头（第一行）
        headers = GetRowValues(rowNodes(0), nsManager)
        ' 创建或打开表
        Set db = CurrentDb()
        CreateTableIfNotExists db, tblName, headers
        Set rs = db.OpenRecordset(tblName, dbOpenDynaset)
        
        ' 遍历数据行（从第二行开始）
        For i = 1 To rowNodes.Length - 1
            dataRow = GetRowValues(rowNodes(i), nsManager)
            ' 确保数据长度和表头一致
            If UBound(dataRow) = UBound(headers) Then
                rs.AddNew
                For j = 0 To UBound(headers)
                    rs(headers(j)) = dataRow(j)
                Next j
                rs.Update
            End If
        Next i
        rs.Close
        MsgBox tblName & " 数据表导入完成！", vbInformation
    Else
        MsgBox "未找到" & tblName & "工作表", vbExclamation
    End If
    
    ' 处理CustomInfo工作表
    tblName = "CustomInfo"
    Set wsNode = xmlDoc.SelectSingleNode("//ss:Worksheet[@ss:Name='" & tblName & "']", nsManager)
    If Not wsNode Is Nothing Then
        Set tableNode = wsNode.SelectSingleNode("ss:Table", nsManager)
        Set rowNodes = tableNode.SelectNodes("ss:Row", nsManager)
        
        headers = GetRowValues(rowNodes(0), nsManager)
        Set db = CurrentDb()
        CreateTableIfNotExists db, tblName, headers
        Set rs = db.OpenRecordset(tblName, dbOpenDynaset)
        
        For i = 1 To rowNodes.Length - 1
            dataRow = GetRowValues(rowNodes(i), nsManager)
            If UBound(dataRow) = UBound(headers) Then
                rs.AddNew
                For j = 0 To UBound(headers)
                    rs(headers(j)) = dataRow(j)
                Next j
                rs.Update
            End If
        Next i
        rs.Close
        MsgBox tblName & " 数据表导入完成！", vbInformation
    Else
        MsgBox "未找到" & tblName & "工作表", vbExclamation
    End If
    
    ' 释放对象
    Set rs = Nothing
    Set db = Nothing
    Set rowNodes = Nothing
    Set tableNode = Nothing
    Set wsNode = Nothing
    Set nsManager = Nothing
    Set xmlDoc = Nothing
End Sub

' 辅助函数：获取某一行的所有单元格值
Private Function GetRowValues(rowNode As MSXML2.IXMLDOMNode, nsManager As MSXML2.IXMLDOMNamespaceManager) As Variant
    Dim cellNodes As MSXML2.IXMLDOMNodeList
    Dim cellNode As MSXML2.IXMLDOMNode
    Dim values() As String
    Dim i As Integer
    
    Set cellNodes = rowNode.SelectNodes("ss:Cell", nsManager)
    ReDim values(cellNodes.Length - 1)
    
    For i = 0 To cellNodes.Length - 1
        Set cellNode = cellNodes(i).SelectSingleNode("ss:Data", nsManager)
        If Not cellNode Is Nothing Then
            values(i) = cellNode.Text
        Else
            values(i) = ""
        End If
    Next i
    
    GetRowValues = values
End Function

' 辅助函数：如果表不存在则创建
Private Sub CreateTableIfNotExists(db As DAO.Database, tblName As String, headers As Variant)
    Dim tblDef As DAO.TableDef
    Dim fld As DAO.Field
    
    ' 检查表是否存在
    On Error Resume Next
    Set tblDef = db.TableDefs(tblName)
    On Error GoTo 0
    
    If tblDef Is Nothing Then
        ' 创建新表
        Set tblDef = db.CreateTableDef(tblName)
        For Each header In headers
            Set fld = tblDef.CreateField(header, dbText, 255) ' 默认用文本类型，可根据需求调整
            tblDef.Fields.Append fld
        Next header
        db.TableDefs.Append tblDef
    End If
    
    Set fld = Nothing
    Set tblDef = Nothing
End Sub

代码说明 #

1. 文件选择：用FileDialog让用户选择本地XML文件，避免硬编码路径
2. XML解析：使用MSXML2.DOMDocument60加载XML，通过命名空间管理器定位到指定工作表（因为XML带Excel的命名空间，必须指定才能正确查询节点）
3. 表头与数据提取：通过GetRowValues函数提取每行的单元格内容，第一行作为表头，后续行作为数据
4. 表创建逻辑：CreateTableIfNotExists函数会检查Access中是否存在目标表，不存在则自动创建（默认字段为文本类型，可根据实际数据修改）
5. 数据插入：遍历数据行，将内容追加到对应数据表中

注意事项 #

• 需先添加引用：打开VBA编辑器 → 工具 → 引用 → 勾选Microsoft XML, v6.0
• 如果需要修改字段数据类型，可在CreateTableIfNotExists函数中调整dbText为对应类型（比如dbDate、dbLong等）
• 若XML中存在空单元格，代码会自动填充为空字符串，避免插入错误

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