XML转Excel的VBA代码大全 复制粘贴即可用的宏脚本

Sub ImportXMLToExcel()
    Dim xmlDoc As Object
    Dim xmlFile As String
    Dim tableNode As Object, rowNode As Object, fieldNode As Object
    Dim iRow As Long, iCol As Long
    Dim headers As Object
    Set headers = CreateObject("Scripting.Dictionary")
<pre class='brush:php;toolbar:false;'>' 修改为你的XML文件路径
xmlFile = "C:\Temp\data.xml"

Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.validateOnParse = False
If Not xmlDoc.Load(xmlFile) Then
    MsgBox "加载XML失败，请检查路径或格式", vbCritical
    Exit Sub
End If

' 清空当前工作表
Cells.Clear

' 假设根下是 <Table>，每条记录是 <Row>
Set tableNode = xmlDoc.DocumentElement
iRow = 1

For Each rowNode In tableNode.ChildNodes
    iCol = 1
    For Each fieldNode In rowNode.ChildNodes
        ' 写入表头（首次出现的字段）
        If iRow = 1 Then
            If Not headers.Exists(fieldNode.BaseName) Then
                Cells(iRow, iCol).Value = fieldNode.BaseName
                headers.Add fieldNode.BaseName, iCol
                iCol = iCol + 1
            End If
        Else
            ' 查找对应列号并写入数据
            If headers.Exists(fieldNode.BaseName) Then
                Cells(iRow, headers(fieldNode.BaseName)).Value = fieldNode.Text
            End If
        End If
    Next fieldNode
    iRow = iRow + 1
Next rowNode

MsgBox "XML导入完成！", vbInformation

Sub ImportXMLWithAttributes()
    Dim xmlDoc As Object
    Dim xmlFile As String
    Dim itemNode As Object, attr As Object
    Dim iRow As Long, colDict As Object
    Set colDict = CreateObject("Scripting.Dictionary")
<pre class='brush:php;toolbar:false;'>xmlFile = "C:\Temp\items.xml"  ' 修改路径

Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
If Not xmlDoc.Load(xmlFile) Then
    MsgBox "无法加载XML文件", vbCritical
    Exit Sub
End If

Cells.Clear
iRow = 1

' 遍历所有 Item 节点（根据实际标签名调整）
For Each itemNode In xmlDoc.SelectNodes("//Item")  ' 可改为 //Product 等
    If iRow = 1 Then
        ' 写入表头：属性名
        For Each attr In itemNode.Attributes
            Cells(1, iRow).Value = attr.Name
            colDict(attr.Name) = iRow
            iRow = iRow + 1
        Next attr
    End If

    iRow = iRow + 1
    For Each attr In itemNode.Attributes
        If colDict.Exists(attr.Name) Then
            Cells(iRow, colDict(attr.Name)).Value = attr.Value
        End If
    Next attr
Next itemNode

MsgBox "带属性的XML导入完成！"

Sub BrowseAndImportXML()
    Dim fDialog As Object
    Dim xmlDoc As Object
    Dim xmlFile As String
<pre class='brush:php;toolbar:false;'>Set fDialog = Application.FileDialog(3) ' msoFileDialogFilePicker
With fDialog
    .Title = "请选择XML文件"
    .Filters.Add "XML Files", "*.xml", 1
    If .Show = -1 Then
        xmlFile = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

' 调用第一个脚本逻辑（可整合）
Call LoadXMLData(xmlFile)

Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.async = False
xmlDoc.validateOnParse = False
If Not xmlDoc.Load(xmlPath) Then
    MsgBox "解析失败：" & Err.Description
    Exit Sub
End If

Cells.Clear
iRow = 1

Set tableNode = xmlDoc.DocumentElement
For Each rowNode In tableNode.ChildNodes
    iCol = 1
    For Each fieldNode In rowNode.ChildNodes
        If iRow = 1 Then
            If Not headers.Exists(fieldNode.BaseName) Then
                Cells(iRow, iCol).Value = fieldNode.BaseName
                headers(fieldNode.BaseName) = iCol
                iCol = iCol + 1
            Else
                iCol = headers(fieldNode.BaseName)
            End If
        Else
            iCol = headers(fieldNode.BaseName)
        End If
        Cells(iRow, iCol).Value = fieldNode.Text
    Next fieldNode
    iRow = iRow + 1
Next rowNode

MsgBox "已导入：" & xmlPath

Sub ImportXMLViaADODB()
    Dim conn As Object, rs As Object
    Dim xmlFile As String
<pre class='brush:php;toolbar:false;'>xmlFile = "C:\Temp\data.xml"  ' 修改路径

Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
          Left(xmlFile, InStrRev(xmlFile, "\")) & ";" & _
          "Extended Properties='text;HDR=YES;FMT=Delimited'"

' 注意：此方法依赖XML已映射为文本表，更适合CSV式XML
' 更推荐DOM方式处理复杂结构

' 示例查询（根据实际schema调整）
rs.Open "SELECT * FROM [" & Mid(xmlFile, InStrRev(xmlFile, "\") + 1) & "]", conn

' 输出到Excel
ActiveSheet.Cells.CopyFromRecordset rs

rs.Close
conn.Close
MsgBox "导入完成（ADODB）"