Created
November 19, 2015 19:57
-
-
Save TABETA/82ec45533635f322c348 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment