VBA 出力EXCLE的数据成xml （带层次关系）

Public Sub Workbook_BeforeSave()

    Dim fileName As String
    Dim firstIndex As Integer
    Dim lastIndex As Integer
    Dim rootNodeName As String
    Dim xmlDoc As MSXML2.DOMDocument
   
    fileName = Worksheets(2).Range("B8").Value
    firstIndex = Worksheets(2).Range("B10").Value
    lastIndex = Worksheets(2).Range("B11").Value
    rootNodeName = Worksheets(2).Range("B12").Value
   
    If fileName = "" Then
        MsgBox ("僼傽僀儖僷僗傪巜掕偔偩偝偄丅")
        Exit Sub
    End If
   
    Set xmlDoc = New MSXML2.DOMDocument
   
    Set rootNode = xmlDoc.createElement(rootNodeName)
    Set xmlDoc.DocumentElement = rootNode
    Set Header = xmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
    xmlDoc.InsertBefore Header, xmlDoc.ChildNodes(0)
   
    xmlDoc.Save fileName
    Set xmlDoc = Nothing
   
    Call OutputSchema(fileName, firstIndex, lastIndex)
   
End Sub

Public Sub OutputSchema(fileName, firstIndex, lastIndex)
    Dim caseIndex As Integer
    Dim pmstartIndex As Integer
   
    'case僨乕僞start
    caseIndex = Worksheets(1).Range("IV1").End(xlToLeft).Column
   
    '僷儔儊乕僞楍栚傪庢摼
    For i = 1 To caseIndex
        cellValue = Worksheets(1).Cells(1, i).Value
        If cellValue = "pmstart" Then
            pmstartIndex = i
            Exit For
        End If
    Next
   
    Dim nodeIndex As Integer
    Dim xmlNode(100)     As IXMLDOMElement '梫慺

    Set xmlDoc = New MSXML2.DOMDocument
    xmlDoc.Load fileName

    Set Root = xmlDoc.DocumentElement
    Set xmlNode(1) = Root
    For nodeIndex = firstIndex To lastIndex
        nodeName = Worksheets(1).Cells(nodeIndex, pmstartIndex).Value
        attrValue = Worksheets(1).Cells(nodeIndex, pmstartIndex + 1).Value
        caseValue = Worksheets(1).Cells(nodeIndex, pmstartIndex + 2).Value
       
        For j = 2 To pmstartIndex
            PmName = Worksheets(1).Cells(nodeIndex, j).Value
            nextPmName = Worksheets(1).Cells(nodeIndex + 1, j + 1).Value
            If Not PmName = "" Then
                Set xmlNode(j) = xmlNode(j - 1).appendChild(xmlDoc.createElement(nodeName))
                If Not attrValue = "" Then
                    Set xmlAttr = xmlNode(j).Attributes.setNamedItem(xmlDoc.createAttribute("nameSpace"))
                    xmlAttr.nodeValue = attrValue
                End If
                If nextPmName = "" Or j = pmstartIndex - 1 Then
                    xmlNode(j).Text = caseValue & vbCrLf
                End If

                Exit For
            End If
        Next
    Next
    xmlDoc.Save fileName
    Set xmlDoc = Nothing
End Sub