如何修改VBA代码将不同结构XML文件的公共列导入Access数据库

原代码直接使用Application.ImportXML会按每个XML的原始结构导入，无法筛选公共列。要实现需求，需要手动解析XML、提取公共列、统一导入，具体修改如下：

修正原代码的基础问题 #

原代码中有一行strFile = Dir(strPath & A)是无效的（变量A未定义），会导致第一个XML文件被跳过，需先删除这行。

完整修改后的VBA代码 #

Private Sub Command5_Click()
    Dim strFile As String       ' 单个文件名
    Dim strFileList() As String ' 文件数组
    Dim intFile As Integer      ' 文件计数
    Dim strPath As String       ' XML文件夹路径
    Dim colColumns As New Collection ' 存储每个文件的列名集合
    Dim dictCommonCols As New Scripting.Dictionary ' 存储公共列（键为列名，值为出现次数）
    Dim xmlDoc As New MSXML2.DOMDocument60 ' XML解析对象
    Dim xmlNodes As MSXML2.IXMLDOMNodeList ' XML记录节点集合
    Dim xmlNode As MSXML2.IXMLDOMNode ' 单个记录节点
    Dim xmlChild As MSXML2.IXMLDOMNode ' 单个字段节点
    Dim targetTableName As String ' 目标表名
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim colName As Variant
    Dim i As Integer
    
    ' 设置文件夹路径
    strPath = "D:\XML\"
    ' 获取所有XML文件
    strFile = Dir(strPath & "*.XML")
    
    ' 第一步：遍历所有XML，收集列名并找出公共列
    While strFile <> ""
        intFile = intFile + 1
        ReDim Preserve strFileList(1 To intFile)
        strFileList(intFile) = strFile
        
        ' 解析当前XML，提取列名
        xmlDoc.async = False
        xmlDoc.Load strPath & strFile
        If xmlDoc.parseError.ErrorCode <> 0 Then
            MsgBox "解析文件 " & strFile & " 出错：" & xmlDoc.parseError.Reason
            GoTo NextFile
        End If
        
        ' 假设XML的记录节点是<Record>，需根据实际结构修改！
        Set xmlNodes = xmlDoc.SelectNodes("//Record")
        If xmlNodes.Length > 0 Then
            ' 提取第一个记录的所有子节点作为列名
            Set xmlNode = xmlNodes(0)
            For Each xmlChild In xmlNode.ChildNodes
                If xmlChild.NodeType = NODE_ELEMENT Then ' 只取元素节点
                    ' 列名存入集合，避免重复
                    On Error Resume Next
                    colColumns.Add xmlChild.BaseName, Key:=xmlChild.BaseName
                    On Error GoTo 0
                End If
            Next xmlChild
            
            ' 更新公共列计数
            For Each colName In colColumns
                If dictCommonCols.Exists(colName) Then
                    dictCommonCols(colName) = dictCommonCols(colName) + 1
                Else
                    dictCommonCols.Add colName, 1
                End If
            Next colName
            colColumns.RemoveAll ' 清空集合，用于下一个文件
        End If
        
NextFile:
        strFile = Dir()
    Wend
    
    ' 检查是否找到文件
    If intFile = 0 Then
        MsgBox "未找到任何XML文件"
        Exit Sub
    End If
    
    ' 筛选出公共列（出现次数等于文件总数）
    For i = dictCommonCols.Count To 1 Step -1
        If dictCommonCols.Items(i - 1) <> intFile Then
            dictCommonCols.Remove dictCommonCols.Keys(i - 1)
        End If
    Next i
    
    If dictCommonCols.Count = 0 Then
        MsgBox "所有XML文件无公共列"
        Exit Sub
    End If
    
    ' 第二步：创建目标表（如果不存在）
    targetTableName = "XML公共数据"
    Set db = CurrentDb()
    ' 检查表是否存在，不存在则创建
    On Error Resume Next
    db.TableDefs(targetTableName)
    If Err.Number <> 0 Then
        ' 创建表，字段类型默认设为文本（可根据实际需求修改）
        Dim createSql As String
        createSql = "CREATE TABLE [" & targetTableName & "] ("
        For Each colName In dictCommonCols.Keys
            createSql = createSql & "[" & colName & "] TEXT(255), "
        Next colName
        createSql = Left(createSql, Len(createSql) - 2) & ")"
        db.Execute createSql
    End If
    On Error GoTo 0
    
    ' 第三步：遍历XML文件，导入公共列数据
    Set rs = db.OpenRecordset(targetTableName)
    For intFile = 1 To UBound(strFileList)
        xmlDoc.Load strPath & strFileList(intFile)
        If xmlDoc.parseError.ErrorCode <> 0 Then
            MsgBox "导入文件 " & strFileList(intFile) & " 出错：" & xmlDoc.parseError.Reason
            GoTo NextImport
        End If
        
        Set xmlNodes = xmlDoc.SelectNodes("//Record")
        For Each xmlNode In xmlNodes
            rs.AddNew
            ' 只提取公共列的数据
            For Each colName In dictCommonCols.Keys
                ' 查找当前记录中对应列的节点
                Set xmlChild = xmlNode.SelectSingleNode(colName)
                If Not xmlChild Is Nothing Then
                    rs(colName) = xmlChild.Text
                Else
                    rs(colName) = Null ' 无对应列则设为空
                End If
            Next colName
            rs.Update
        Next xmlNode
        
NextImport:
    Next intFile
    
    ' 清理对象
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set xmlDoc = Nothing
    Set xmlNodes = Nothing
    
    MsgBox "导入完成，共处理 " & intFile & " 个文件，目标表：" & targetTableName
End Sub

关键修改说明 #

• 添加XML解析逻辑：使用MSXML2.DOMDocument60手动解析XML，替代自动导入，实现列筛选。
• 公共列识别：通过字典统计每个列在所有文件中的出现次数，筛选出所有文件都存在的列。
• 统一数据导入：创建统一的目标表，仅将公共列的数据插入表中，忽略非公共列。
• 需自定义的部分：代码中//Record是XML记录节点的XPath，需根据你的实际XML结构修改（比如你的XML中每个数据行是或其他节点，要对应修改）。
• 引用依赖：需在VBA编辑器中添加对Microsoft XML, v6.0和Microsoft Scripting Runtime的引用（工具→引用）。

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