2024年3月23日 / 最終更新日時 : 2024年3月25日 alljapan Excel

シートから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 rw

16行目から最後の行までを繰り返します。各行の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 4

iが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 If

tagが空でない場合、以下の処理を行います。

ノードの設定を行います。次のタグが空の場合は、値を持つノードを作成し、次のタグが空でない場合、値なしのノードを作成します。最後のタグの次のタグは空白にしたいので、シートの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.CodeBeautify

XMLのコードを整形し、インデントを整えます。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.ChangeEncoding

UTF-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ファイルです。

アイコン

シートからXML作成

1 ファイル 29.78 KB
ダウンロード

この投稿に関する追加解説です。

XMLファイルのインデント整形
XMLファイルを読み込み、各種変更して、XMLファイルとして保存

Follow me!

カテゴリー
Excel、VBA、XML、マクロ
Excel

前の記事

セルの文字を変換、小文字大文字、半角全角、ひらがなカタカナ
2024年3月16日
Excel

次の記事

XMLファイルのインデント整形
2024年3月23日