以下は、必要なフィールドを出力する 2 つの方法です。投稿した XML には名前空間「xa:」のヘッダー定義が含まれていないため、完全な形式の XML ではないことに注意してください。MSXML2.DOMDocument が解析エラーをスローしないように、例ではそれらを削除しました。
Option Explicit
Sub XMLMethod()
Dim XMLString As String
Dim XMLDoc As Object
Dim boolValue As Boolean
Dim xmlDocEl As Object
Dim xMeContext As Object
Dim xChild As Object
Dim xorder As Object
XMLString = Sheet1.Range("A1").Value
'Remove xa: in this example
'reason : "Reference to undeclared namespace prefix: 'xa'."
'Shouldn't need to do this if full XML is well formed containing correct namespace
XMLString = Replace(XMLString, "xa:", vbNullString)
Set XMLDoc = CreateObject("MSXML2.DOMDocument")
'XMLDoc.setProperty "SelectionNamespaces", "xa:"
'XMLDoc.Load = "C:\Users\ooo\Desktop\test.xml" 'load from file
boolValue = XMLDoc.LoadXML(XMLString) 'load from string
Set xmlDocEl = XMLDoc.DocumentElement
Set xMeContext = xmlDocEl.SelectSingleNode("//MeContext")
Debug.Print Split(xMeContext.XML, """")(1)
For Each xChild In xmlDocEl.ChildNodes
If xChild.NodeName = "Orders" Then
For Each xorder In xChild.ChildNodes
Debug.Print Split(xorder.XML, """")(1)
Debug.Print xorder.Text
Next xorder
ElseIf xChild.Text = "" Then
Debug.Print Split(xChild.XML, """")(1)
Else
Debug.Print xChild.Text
End If
Next xChild
'Output:
'ABCe0552553
'ABCe05525531
'1
'Cust1234
'Smith
'New York
'101
'MP3 Player
'102
'Radio
End Sub
そして、以下では正規表現を使用しています。これは、XML が毎回正確に例に固定されている場合にのみ役立ちます。信頼性よりも速度が必要でない限り、一般的な XML の解析にはあまりお勧めできません。
Option Explicit
Sub RegexMethod()
Dim XMLString As String
Dim oRegex As Object
Dim regexArr As Object
Dim rItem As Object
'Assumes Sheet1.Range("A1").Value holds example XMLString
XMLString = Sheet1.Range("A1").Value
Set oRegex = CreateObject("vbscript.regexp")
With oRegex
.Global = True
.Pattern = "(id=""|>)(.+?)(""|</)"
Set regexArr = .Execute(XMLString)
'No lookbehind so replace unwanted chars
.Pattern = "(id=""|>|""|</)"
For Each rItem In regexArr
'Change Debug.Print to fill an array to write to Excel
Debug.Print .Replace(rItem, vbNullString)
Next rItem
End With
'Output:
'ABCe0552553
'ABCe05525531
'1
'Cust1234
'Smith
'New York
'101
'MP3 Player
'102
'Radio
End Sub
編集:範囲への書き込みのために配列への出力をわずかに更新
Option Explicit
Sub RegexMethod()
Dim XMLString As String
Dim oRegex As Object
Dim regexArr As Object
Dim rItem As Object
Dim writeArray(1 To 1, 1 To 10) As Variant
Dim col As Long
'Assumes Sheet1.Range("A1").Value holds example XMLString
XMLString = Sheet1.Range("A1").Value
Set oRegex = CreateObject("vbscript.regexp")
With oRegex
.Global = True
.Pattern = "(id=""|>)(.+?)(""|</)"
Set regexArr = .Execute(XMLString)
'No lookbehind so replace unwanted chars
.Pattern = "(id=""|>|""|</)"
For Each rItem In regexArr
'Change Debug.Print to fill an array to write to Excel
Debug.Print .Replace(rItem, vbNullString)
col = col + 1
writeArray(1, col) = .Replace(rItem, vbNullString)
Next rItem
End With
Sheet1.Range("A5:J5").Value = writeArray
End Sub
Sub XMLMethod()
Dim XMLString As String
Dim XMLDoc As Object
Dim boolValue As Boolean
Dim xmlDocEl As Object
Dim xMeContext As Object
Dim xChild As Object
Dim xorder As Object
Dim writeArray(1 To 1, 1 To 10) As Variant
Dim col As Long
XMLString = Sheet1.Range("A1").Value
'Remove xa: in this example
'reason : "Reference to undeclared namespace prefix: 'xa'."
'Shouldn't need to do this if full XML is well formed
XMLString = Replace(XMLString, "xa:", vbNullString)
Set XMLDoc = CreateObject("MSXML2.DOMDocument")
'XMLDoc.setProperty "SelectionNamespaces", "xa:"
'XMLDoc.Load = "C:\Users\ooo\Desktop\test.xml" 'load from file
boolValue = XMLDoc.LoadXML(XMLString) 'load from string
Set xmlDocEl = XMLDoc.DocumentElement
Set xMeContext = xmlDocEl.SelectSingleNode("//MeContext")
'Debug.Print Split(xMeContext.XML, """")(1)
col = col + 1
writeArray(1, col) = Split(xMeContext.XML, """")(1)
For Each xChild In xmlDocEl.ChildNodes
If xChild.NodeName = "Orders" Then
For Each xorder In xChild.ChildNodes
col = col + 1
'Debug.Print Split(xorder.XML, """")(1)
writeArray(1, col) = Split(xorder.XML, """")(1)
col = col + 1
'Debug.Print xorder.Text
writeArray(1, col) = xorder.Text
Next xorder
ElseIf xChild.Text = "" Then
col = col + 1
'Debug.Print Split(xChild.XML, """")(1)
writeArray(1, col) = Split(xChild.XML, """")(1)
Else
col = col + 1
'debug.Print xChild.Text
writeArray(1, col) = xChild.Text
End If
Next xChild
Sheet1.Range("A5:J5").Value = writeArray
End Sub