シートからXML作成、タグ追加関数、属性追加関数、インデント整形、エンコーティング
以下のシートから、XMLファイルを作成するマクロの紹介です。
マクロを実行すると、以下のXMLファイルが作成されます。
<?xml version="1.0" encoding="UTF-8"?>
<all>
<row>
<A attrid="attrV">
<AA>データ１</AA>
<C id="text">データ２</C>
</A>
<D>
<E>データ３</E>
<F>データ４</F>
</D>
<G>
<H>
<I klm="post">
<J year="2024">データ５</J>
<K>データ６</K>
</I>
<L>データ７</L>
</H>
<M>データ８<N>データ９</N>
</M>
</G>
<O>データ１０</O>
</row>
<row>
<A attrid="attrV">
<AA>データ１１</AA>
<C id="text">データ１２</C>
</A>
<D>
<E>データ１３</E>
<F>データ１４</F>
</D>
<G>
<H>
<I klm="post">
<J year="2024">データ１５</J>
<K>データ１６</K>
</I>
<L>データ１７</L>
</H>
<M>データ１８<N>データ１９</N>
</M>
</G>
<O>データ２０</O>
</row>
<row>
<A attrid="attrV">
<AA>２１</AA>
<C id="text"/>
</A>
<D>
<E>２３</E>
<F>２４</F>
</D>
<G>
<H>
<I klm="post">
<J year="2024"/>
<K>２６</K>
</I>
<L/>
</H>
<M>２８<N/>
</M>
</G>
<O/>
</row>
</all>全体は<all>タグで囲まれていて、16行の値を元に、1～12行に設定しているタグと属性を元に、<row>タグに囲まれたxmlを作成しています。16行と同じように、18行目まで、xmlを作成しています。
以下が、マクロです。このマクロはMSXML2.DOMDocument60オブジェクトを使用するため、「Microsoft XML v6.0」の参照設定が必要です。
Option Explicit
Sub MakeXML()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
' XMLの書き込み準備を行う
Dim xw As XmlWriter ' クラス
Set xw = New XmlWriter
xw.Prepare ' 準備
' 複数行繰り返し
Dim lastRw As Long ' A列、最後の行
lastRw = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim rw As Long ' 行
For rw = 16 To lastRw
' 各行のNode作成
Call xw.AppendElement(ws, rw)
Next rw
' ルートNodeに追加
xw.AppendRoot
' xmlのインデント整形
xw.CodeBeautify
' UTF-16からUTF-8に変換
xw.ChangeEncoding
' XMLファイルに書き込む
Dim outputFileName As String ' 出力ファイル
outputFileName = ThisWorkbook.path & _
"\出力ファイル_" & Format(Now, "yyyymmddhhmmss") & ".xml"
xw.Save (outputFileName)
Set xw = Nothing
End Sub以下は、クラスモジュールに入れたクラス「XmlWriter」のマクロです。
' DOM
Private xmlDocument As MSXML2.DOMDocument60
'出力用DOM
Private xmlDoc2 As New MSXML2.DOMDocument60
' ルート要素のノード
Private rootNode As IXMLDOMNode
' ルート以降のノード
Private Node(0 To 4) As IXMLDOMNode
' コンストラクタ
Public Sub class_initialize()
End Sub
' ファイルの書き込み準備を行う
Public Sub Prepare()
' MSXMLオブジェクトを生成
Set xmlDocument = Nothing
Set xmlDocument = New MSXML2.DOMDocument60
' XML宣言を生成
Dim processingInstruction As IXMLDOMProcessingInstruction
Set processingInstruction = xmlDocument.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
Call xmlDocument.appendChild(processingInstruction)
' 共通要素/属性を生成
Set rootNode = xmlDocument.appendChild(xmlDocument.createElement("all"))
End Sub
' 各Node作成
Public Sub AppendElement(ByVal ws As Worksheet, ByVal rw As Long)
Dim str As String ' 値
Dim tag As String ' タグ
Dim nextTag As String ' 次のタグ
Dim attrType As String ' 属性名
Dim attrValue As String ' 属性値
Dim i As Long ' タグの繰り返し
' 1行全体のノード
Set Node(0) = AppendNodeElement(rootNode, "row")
' 列繰り返し
Dim clm As Long
Dim lastClm As Long
lastClm = ws.Cells(15, Columns.Count).End(xlToLeft).Column
For clm = 2 To lastClm
str = ws.Cells(rw, clm) ' 値
For i = 1 To 4
tag = ws.Cells(i * 3 - 2, clm) ' タグ
nextTag = ws.Cells(i * 3 + 1, clm) ' 次のタグ
attrType = ws.Cells(i * 3 - 1, clm) ' 属性名
attrValue = ws.Cells(i * 3, clm) ' 属性値
If tag <> "" Then
' ノードの設定。次のタグが空白の場合、内容を入れる
If nextTag = "" Then
Set Node(i) = AppendNodeElement(Node(i - 1), tag, str)
Else
Set Node(i) = AppendNodeElement(Node(i - 1), tag)
End If
' 属性の設定
If attrType <> "" Then
Call AppendAttr(Node(i), attrType, attrValue)
End If
End If
Next i
Next clm
End Sub
'***********************************
'* 子ノードの作成
'* 戻り値：子ノード
'* Node：ノード、このノードの子ノードを追加
'* elementName：子ノードのタグ名
'* nodeText：子ノードの内容
Private Function AppendNodeElement(ByVal Node As IXMLDOMNode, ByVal elementName As String, Optional nodeText As String) As IXMLDOMNode
Dim appendNode As IXMLDOMNode
Set appendNode = xmlDocument.createElement(elementName)
appendNode.Text = nodeText
Call Node.appendChild(appendNode)
Set AppendNodeElement = appendNode
End Function
'***********************************
'* 属性の追加
'* Node：ノード、このノードに属性を追加
'* attrType：属性名
'* attrValue：属性値
Private Sub AppendAttr(ByVal Node As IXMLDOMNode, ByVal attrType As String, ByVal attrValue As String)
Dim idAttribute As MSXML2.IXMLDOMAttribute
Set idAttribute = xmlDocument.createAttribute(attrType)
idAttribute.NodeValue = attrValue
Call Node.Attributes.setNamedItem(idAttribute)
End Sub
' 作成したエレメントをrootに追加
Public Sub AppendRoot()
Call rootNode.appendChild(Node(0))
End Sub
' xmlのインデント整形
' https://teratail.com/questions/118314
Public Sub CodeBeautify()
'Reader/Writerを用意する
Dim oXmlReader As New SAXXMLReader60
Dim oXmlWriter As New MXXMLWriter60
'Writerでインデント設定する
oXmlWriter.indent = True
'ReaderとWriterを紐づける
Set oXmlReader.contentHandler = oXmlWriter
'作成したXMLをReaderで読み込む
oXmlReader.Parse xmlDocument.XML
'出力用DOMにWriterの整形結果を読ませる
xmlDoc2.LoadXML oXmlWriter.output
End Sub
' XMLファイルのencodingの変更
' https://tsuyorid.hatenadiary.org/entry/20051216/p2
Public Sub ChangeEncoding()
' UTF-16からUTF-8に変換
Dim domDecXml As IXMLDOMProcessingInstruction
'UTF-8に変換
Set domDecXml = xmlDoc2.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
'元々のencodingを無視して変更する
Call xmlDoc2.replaceChild(domDecXml, xmlDoc2.FirstChild)
End Sub
' XMLファイルを保存する
Public Sub Save(filePath As String)
If xmlDoc2.XML = "" Then
xmlDocument.Save (filePath)
Else
'出力用DOMで保存
xmlDoc2.Save (filePath)
End If
End Sub
' デストラクタ
Public Sub Class_Terminate()
If Not xmlDocument Is Nothing Then Set xmlDocument = Nothing
If Not xmlDoc2 Is Nothing Then Set xmlDoc2 = Nothing
If Not rootNode Is Nothing Then Set rootNode = Nothing
Dim i As Long
For i = LBound(Node) To UBound(Node)
If Not Node(i) Is Nothing Then Set Node(i) = Nothing
Next i
End Sub順番に解説します。
' XMLの書き込み準備を行う
Dim xw As XmlWriter ' クラス
Set xw = New XmlWriter
xw.Prepare ' 準備XmlWriterというクラスの新しいインスタンスを作成して、XmlWriterクラスに設定されている以下「Prepare」を実行します。
' ファイルの書き込み準備を行う
Public Sub Prepare()
' MSXMLオブジェクトを生成
Set xmlDocument = Nothing
Set xmlDocument = New MSXML2.DOMDocument60
' XML宣言を生成
Dim processingInstruction As IXMLDOMProcessingInstruction
Set processingInstruction = xmlDocument.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
Call xmlDocument.appendChild(processingInstruction)
' 共通要素/属性を生成
Set rootNode = xmlDocument.appendChild(xmlDocument.createElement("all"))
End Subこのサブルーチンでは、XMLの書き込みの準備を行っています。具体的には、MSXMLオブジェクトを生成し、XML宣言を生成し、共通要素/属性を生成しています。ルートノードのタグは、<all>にしています。
' 複数行繰り返し
Dim lastRw As Long ' A列、最後の行
lastRw = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim rw As Long ' 行
For rw = 16 To lastRw
' 各行のNode作成
Call xw.AppendElement(ws, rw)
Next rw16行目から最後の行までを繰り返します。各行のNodeを作成するため、XmlWriterクラスに設定されている以下「AppendElement」を実行します。引数として、ワークシート「ws」と行「rw」を渡しています。
' 各Node作成
Public Sub AppendElement(ByVal ws As Worksheet, ByVal rw As Long)このサブルーチンは、各Nodeを作成するためのもので、中身は、以下になります。
Dim str As String ' 値
Dim tag As String ' タグ
Dim nextTag As String ' 次のタグ
Dim attrType As String ' 属性名
Dim attrValue As String ' 属性値
Dim i As Long ' タグの繰り返し変数を宣言します。
' 1行全体のノード
Set Node(0) = AppendNodeElement(rootNode, "row")1行全体のノードを作成し、Node(0)に代入します。タグは、<row>にしています。
' 列繰り返し
Dim clm As Long
Dim lastClm As Long
lastClm = ws.Cells(15, Columns.Count).End(xlToLeft).Column
For clm = 2 To lastClm列の繰り返し処理を行います。2列目から15行目の最後の列までを対象にします。
str = ws.Cells(rw, clm) ' 値値「str」に、rw行clm列のセルの内容を代入します。rwは16～18、clmは2（Ｂ列）～11（K列）と増加しながら処理します。
For i = 1 To 4iが1から4までの間、繰り返します。タグが、4重で囲えるように、シートを作成しているので、1～4にしています。
tag = ws.Cells(i * 3 - 2, clm) ' タグ
nextTag = ws.Cells(i * 3 + 1, clm) ' 次のタグ
attrType = ws.Cells(i * 3 - 1, clm) ' 属性名
attrValue = ws.Cells(i * 3, clm) ' 属性値tag、nextTag、attrType、attrValueにそれぞれセルの内容を代入します。
If tag <> "" Then
' ノードの設定。次のタグが空白の場合、内容を入れる
If nextTag = "" Then
Set Node(i) = AppendNodeElement(Node(i - 1), tag, str)
Else
Set Node(i) = AppendNodeElement(Node(i - 1), tag)
End If
' 属性の設定
If attrType <> "" Then
Call AppendAttr(Node(i), attrType, attrValue)
End If
End Iftagが空でない場合、以下の処理を行います。
ノードの設定を行います。次のタグが空の場合は、値を持つノードを作成し、次のタグが空でない場合、値なしのノードを作成します。最後のタグの次のタグは空白にしたいので、シートの13行目は空白行にしています。「AppendNodeElement」は、次に解説します。
属性の設定を行います。属性が空でない場合、属性を追加します。「AppendAttr」は、次の次に解説します。
'***********************************
'* 子ノードの作成
'* 戻り値：子ノード
'* Node：ノード、このノードの子ノードを追加
'* elementName：子ノードのタグ名
'* nodeText：子ノードの内容
Private Function AppendNodeElement(ByVal Node As IXMLDOMNode, ByVal elementName As String, Optional nodeText As String) As IXMLDOMNode
Dim appendNode As IXMLDOMNode
Set appendNode = xmlDocument.createElement(elementName)
appendNode.Text = nodeText
Call Node.appendChild(appendNode)
Set AppendNodeElement = appendNode
End Function新しい子ノードを作成し、指定された親ノードに追加するための関数です。戻り値は、作成した子ノードになっています。
'***********************************
'* 属性の追加
'* Node：ノード、このノードに属性を追加
'* attrType：属性名
'* attrValue：属性値
Private Sub AppendAttr(ByVal Node As IXMLDOMNode, ByVal attrType As String, ByVal attrValue As String)
Dim idAttribute As MSXML2.IXMLDOMAttribute
Set idAttribute = xmlDocument.createAttribute(attrType)
idAttribute.NodeValue = attrValue
Call Node.Attributes.setNamedItem(idAttribute)
End Sub指定されたノードに属性を追加するためのサブルーチンです。
' ルートNodeに追加
xw.AppendRoot標準モジュールプロシージャ「MakeXML」に戻ります。ルートNodeに子ノードを追加します。XmlWriterクラスに設定されている以下「AppendRoot」を実行します。
' 作成したエレメントをrootに追加
Public Sub AppendRoot()
Call rootNode.appendChild(Node(0))
End Sub ' xmlのインデント整形
xw.CodeBeautifyXMLのコードを整形し、インデントを整えます。XmlWriterクラスに設定されている以下「CodeBeautify」を実行します。
' xmlのインデント整形
' https://teratail.com/questions/118314
Public Sub CodeBeautify()
'Reader/Writerを用意する
Dim oXmlReader As New SAXXMLReader60
Dim oXmlWriter As New MXXMLWriter60
'Writerでインデント設定する
oXmlWriter.indent = True
'ReaderとWriterを紐づける
Set oXmlReader.contentHandler = oXmlWriter
'作成したXMLをReaderで読み込む
oXmlReader.Parse xmlDocument.XML
'出力用DOMにWriterの整形結果を読ませる
xmlDoc2.LoadXML oXmlWriter.output
End Sub「https://teratail.com/questions/118314」を参考にしています。
' UTF-16からUTF-8に変換
xw.ChangeEncodingUTF-16形式からUTF-8形式にエンコーディングを変換します。XmlWriterクラスに設定されている以下「ChangeEncoding」を実行します。
' XMLファイルのencodingの変更
' https://tsuyorid.hatenadiary.org/entry/20051216/p2
Public Sub ChangeEncoding()
' UTF-16からUTF-8に変換
Dim domDecXml As IXMLDOMProcessingInstruction
'UTF-8に変換
Set domDecXml = xmlDoc2.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
'元々のencodingを無視して変更する
Call xmlDoc2.replaceChild(domDecXml, xmlDoc2.FirstChild)
End Sub「https://tsuyorid.hatenadiary.org/entry/20051216/p2」を参考にしています。
' XMLファイルに書き込む
Dim outputFileName As String ' 出力ファイル
outputFileName = ThisWorkbook.path & _
"\出力ファイル_" & Format(Now, "yyyymmddhhmmss") & ".xml"
xw.Save (outputFileName)出力ファイルの名前を作成し、XMLファイルに書き込みます。XmlWriterクラスに設定されている以下「Save」を実行します。
' XMLファイルを保存する
Public Sub Save(filePath As String)
If xmlDoc2.XML = "" Then
xmlDocument.Save (filePath)
Else
'出力用DOMで保存
xmlDoc2.Save (filePath)
End If
End Sub以下が、このExcelファイルです。
この投稿に関する追加解説です。
Follow me!
