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

XMLファイルを読み込み、各種変更して、XMLファイルとして保存

以下で作成したXMLファイルの追加解説です。

シートから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>２３<br>B</E>
			<F>２４</F>
		</D>
		<G>
			<H>
				<I klm="post">
					<J year="2024"/>
					<K>２６</K>
				</I>
				<L/>
			</H>
			<M>２８<N/>
			</M>
		</G>
		<O/>
	</row>
</all>

このXMLファイルに、以下の変更します。

コメントが消えてしまうので、ここで追加。<row>タグの前に、改行＋<!– row: 「行数」 –>を追加
タグの中の「<」「>」がエスケープ文字「&+lt;」「&+gt;」（この文字は、ここから「+」を削除して読んでください）に変換されてしまうので、ここで元に戻す
空要素があれば、省略した書式ではなく、タグで囲むように変更
改行コードを、「vbLf」に置換します

そのサンプルマクロは、以下です。

' https://www.depthbomb.net/?p=6917
' 引数で渡されたXMLファイルを読み込み、各種変更して、XMLファイルとして保存します。
' ＜変更点＞
' コメントの追加、エスケープ文字を戻す、タグで囲むように変更、改行コードを「vbLf」に置換
Private Sub ReCreateXMLFile(TargetFilePath As String, OutputFilePath As String)
    Dim LineText As String
    Dim AllText As String
    Dim num As Long
    Dim rowNum As Long: rowNum = 1
    Dim myComment As String
    
    'Stramオブジェクトを生成して変換対象のファイルを読み込みます。
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile TargetFilePath
        
        Do Until .EOS
            LineText = .ReadText(-2)
            
            
            ' コメントが消えてしまうので、ここで追加
            If InStr(LineText, "<row") > 0 Then
                myComment = "<!-- row: " & rowNum & " -->"
                LineText = vbCrLf & vbTab & myComment & vbCrLf & LineText
                rowNum = rowNum + 1
            End If
            
            
            ' タグの中の「<」「>」がエスケープ文字「<」「>」に変換されてしまうので、ここで元に戻す
            If InStr(LineText, "<") > 0 Then
                LineText = Replace(LineText, "<", "<")
            End If
            
            If InStr(LineText, ">") > 0 Then
                LineText = Replace(LineText, ">", ">")
            End If
            
        
            ' 空要素があれば、省略した書式ではなく、タグで囲むように変更。
            If Right(LineText, 2) = "/>" Then
                ' 空要素を、タグを囲む文字列に変換
                LineText = ConvertToEnclosedInTag(LineText) & vbCrLf
            Else
                LineText = LineText & vbCrLf
            End If
            
            
            ' 改行コードを、「vbLf」に置換します。
            ' 以下、最終のXMLファイル
            AllText = AllText & Replace(LineText, vbCrLf, vbLf)

        Loop
        .Close
    End With
    '再度Streamオブジェクトを生成して読み込んだテキストからBOMを排除して書き込みます。
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .WriteText AllText, adWriteChar '文字列を書き込み
        
        .Position = 0           'ストリームの位置を0にする
        .Type = adTypeBinary    'データの種類をバイナリデータに変更
        .Position = 3           'ストリームの位置を3にする
        
        Dim byteData() As Byte  '一時格納用
        byteData = .Read        'ストリームの内容を一時格納用変数に保存
        .Close                  '一旦ストリームを閉じる（リセット）
        .Open                   'ストリームを開く
        .Write byteData         'ストリームに一時格納したデータを流し込む
        .SaveToFile OutputFilePath, adSaveCreateOverWrite   '上書き保存
        .Close
    End With
End Sub


' 空要素を、タグを囲む文字列に変換
' <M>２８<N/> → <M>２８<N></N>
' <C id="text"/> →　<C id="text"></C>
Private Function ConvertToEnclosedInTag(ByVal str As String) As String
    ' 「/>」の前の「<」を探す。
    Dim m As Long, n As Long
    n = InStrRev(str, "/>")
    m = InStrRev(str, "<", n)
    
    ' "<" と "/>" の中の文字列
    Dim txt As String
    txt = Mid(str, m + 1, n - m - 1)
    
    ' 文字列に半角空白がある場合は、そこまでの文字列を取得
    Dim txt2 As String
    Dim txt2Num As Long
    txt2Num = InStr(txt, " ")
    If txt2Num > 0 Then
        txt2 = Left(txt, txt2Num - 1)
    Else
        txt2 = txt
    End If
    
    ConvertToEnclosedInTag = Replace(str, "<" & txt & "/>", "<" & txt & "></" & txt2 & ">")
    
End Function

このマクロは、https://www.depthbomb.net/?p=6917 を参考にしています。

以下、使用例です。

Private Sub 使用例()
    Call BackupReCreateXMLFile(ThisWorkbook.path & "\変換前.xml", ThisWorkbook.path & "\変換後.xml")
End Sub

このマクロを実行すると、「変換前.xml」ファイルが、変更され、以下の「変換後.xml」が作成されます。

<?xml version="1.0" encoding="UTF-8"?>
<all>

	<!-- row: 1 -->
	<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: 2 -->
	<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: 3 -->
	<row>
		<A attrid="attrV">
			<AA>２１</AA>
			<C id="text"></C>
		</A>
		<D>
			<E>２３<br>B</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>
</all>

Follow me!

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