VBAでxml

Option Explicit


Dim header() As String
Dim i As Long
Dim row As Long
Dim col As Long

Sub getHeader()
    i = 1
    Do While Worksheets("Sheet1").Cells(1, i).Value <> ""
        ReDim Preserve header(i)
        header(i) = Worksheets("Sheet1").Cells(1, i).Value
        i = i + 1
    Loop
End Sub
Sub showHeader()
    Dim str As String: str = ""
    For i = 1 To UBound(header)
        str = str & header(i)
    Next
    MsgBox str
End Sub

Sub create()
    Dim writer As Object: Set writer = CreateObject("MSXML2.MXXMLWriter")
    Dim reader As Object: Set reader = CreateObject("MSXML2.SAXXMLReader")
    writer.indent = True
    writer.standalone = True
    writer.Encoding = "shift_jis" '無視される，UTF16になる
    Set reader.contentHandler = writer
    Call reader.putProperty("http://xml.org/sax/properties/lexical-handler", writer)
    Dim xmlNode As Object
    Dim xmlObj  As Object: Set xmlObj = CreateObject("MSXML2.DOMDocument")
    Dim xml2 As Object: Set xml2 = CreateObject("MSXML2.DOMDocument")
    
    
    xmlObj.async = False
    xmlObj.setProperty "SelectionLanguage", "XPath"
    xmlObj.appendChild xmlObj.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
    Dim node1 As Object
    Dim node2 As Object
    Dim node3 As Object
    Dim xmlAttr As Object
    
    Call getHeader
    row = 2
    With Worksheets("Sheet1")
        col = 1
        Set main = xmlObj.appendChild(xmlObj.CreateElement("node1"))
        node1.Attributes.setNamedItem(xmlObj.createAttribute(header(col))).NodeValue = .Cells(row, col).Value
        
            col = 2
            node1.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
            
            col = 3
            Set node2 = node1.appendChild(xmlObj.CreateElement("Sub"))
            node2.Attributes.setNamedItem(xmlObj.createAttribute(header(col))).NodeValue = .Cells(row, col).Value
               
                col = 4
                node2.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                col = 5
                node2.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                col = 6
                node2.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                
                Set node3 = node2.appendChild(xmlObj.CreateElement("node3"))
                    col = 7
                    node3.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                    col = 8
                    node3.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                    col = 9
                    node3.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
                    col = 10
                    node3.appendChild(xmlObj.CreateElement(header(col))).appendChild (xmlObj.createTextNode(.Cells(row, col).Value))
        
        
    End With
    reader.Parse xmlObj.XML
    xml2.LoadXML (writer.output)
    xml2.Save (ThisWorkbook.Path & "\result.xml")
    Set xmlNode = Nothing
    Set xmlObj = Nothing
    Set xmlAttr = Nothing
End Sub