使用VBA宏將Excel數據的每一行創建為xml文件

Question

我正在嘗試使用VBA宏將Excel數據的每一行（特定列）創建為xml文件（帶有標簽）。 我能夠創建文件，但是數據沒有填充到xml文件中。 請幫我！！

Option Explicit

Private Sub SaveAs_XML()
On Error GoTo ErrHandle    
    Dim doc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60
    Dim root As IXMLDOMElement, dataNode As IXMLDOMElement, lastnameNode As IXMLDOMElement, AgeNode As IXMLDOMElement
    Dim dataNameAttrib As IXMLDOMAttribute, Attrib As IXMLDOMAttribute
    Dim nameAttrib As IXMLDOMAttribute, lastnameAttrib As IXMLDOMAttribute, AgeAttrib As IXMLDOMAttribute
    Dim i As Long
    Dim Folder As String
    Dim WS_Src As Worksheet, rng As Range, C As Range, d As Range
    Dim fs, f, ts, s
    Dim XDoc

    Folder = "\C:\New folder\"
    Set WS_Src = ThisWorkbook.Worksheets("data")
    Set rng = WS_Src.Range("B1", WS_Src.Range("B" & Rows.Count).End(xlUp))
    For Each C In rng
        Set fs = CreateObject("Scripting.FileSystemObject")
        fs.CreateTextFile Folder & C.Value & ".xml"
        Set f = fs.GetFile(Folder & C.Value & ".xml")
    Next

    Set XDoc = CreateObject("MSXML2.DOMDocument")
    ' DECLARE XML DOC OBJECT '
    Set root = doc.createElement("list")
    doc.appendChild root

    ' WRITE TO XML '
    For i = 2 To Sheets(1).UsedRange.Rows.Count 
            ' DATA NODE '
            Set dataNode = doc.createElement("data")
            root.appendChild dataNode
            ' NAME ATTRIBUTE '
            Set dataNameAttrib = doc.createAttribute("name")
            dataNameAttrib.Value = Range("B" & i)
            dataNode.setAttributeNode dataNameAttrib
            ' LASTNAME ATTRIBUTE '
            Set lastnameAttrib = doc.createAttribute("lastname")
            lastnameAttrib.Value = Range("C" & i)
            lastnameNode.setAttributeNode lastnameAttrib            
            ' AGE ATTRIBUTE '
            Set AgeAttrib = doc.createAttribute("age")
            AgeAttrib.Value = Range("E" & i)
            AgeNode.setAttributeNode AgeAttrib           

    Next i

        ' PRETTY PRINT RAW OUTPUT '
        xslDoc.LoadXML "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>" _
            & "<xsl:stylesheet version=" & Chr(34) & "1.0" & Chr(34) _
            & "                xmlns:xsl=" & Chr(34) & "http://www.w3.org/1999/XSL/Transform" & Chr(34) & ">" _
            & "<xsl:strip-space elements=" & Chr(34) & "*" & Chr(34) & " />" _
            & "<xsl:output method=" & Chr(34) & "xml" & Chr(34) & " indent=" & Chr(34) & "yes" & Chr(34) & "" _
            & "            encoding=" & Chr(34) & "UTF-8" & Chr(34) & "/>" _
            & " <xsl:template match=" & Chr(34) & "node() | @*" & Chr(34) & ">" _
            & "  <xsl:copy>" _
            & "   <xsl:apply-templates select=" & Chr(34) & "node() | @*" & Chr(34) & " />" _
            & "  </xsl:copy>" _
            & " </xsl:template>" _
            & "</xsl:stylesheet>"

        xslDoc.async = False  


    MsgBox "Successfully exported Excel data to XML!", vbInformation
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Exit Sub
End Sub

我希望輸出的每一行都是這樣的（xml文件）

$ Output

<?xml version="1.0" encoding="UTF-8"?>
<List>
    <Data name="test1" 
     lastname="lastname1" 
     age ="24"
    />        
</List>

Answer 1

這應該做您需要的。 沒有xsl，但這沒關系。

您的問題似乎包含彼此之間有些脫節的代碼段，因此我對您要執行的操作做了一些猜測。

Private Sub SaveAs_XML()

    Dim doc As MSXML2.DOMDocument60, pi
    Dim root As IXMLDOMElement, dataNode As IXMLDOMElement
    Dim i As Long

    For i = 2 To Sheets(1).UsedRange.Rows.Count

        Set doc = New MSXML2.DOMDocument60

        Set root = doc.createElement("list")
        doc.appendChild root

        Set dataNode = doc.createElement("data")
        root.appendChild dataNode

        AddAttributeWithValue dataNode, "name", Range("B" & i)
        AddAttributeWithValue dataNode, "lastname", Range("C" & i)
        AddAttributeWithValue dataNode, "age", Range("E" & i)

        Set pi = doc.createProcessingInstruction("xml", "version=""1.0""")
        doc.InsertBefore pi, doc.ChildNodes.Item(0)

        doc.Save "C:\_Stuff\xml\" & Range("B" & i).Value & ".xml"
    Next i

    MsgBox "Successfully exported Excel data to XML!", vbInformation

End Sub

'utility: add an attribute (with a value) to an element
Sub AddAttributeWithValue(el As IXMLDOMElement, attName, attValue)
    Dim att
    Set att = el.OwnerDocument.createAttribute(attName)
    att.Value = attValue
    el.setAttributeNode att
End Sub