VBAでXMLのパースを行う

VBAでxmlファイル読み込み、Excelファイルに書き出します。

<?xml version="1.0" encoding="Shift_JIS"?>
<ROOT>
    <INFO>
        <DATE>2014/01/02</DATE>
        <CUSTOMER>サンプル会社</CUSTOMER>
    </INFO>
    <DATA>
        <PRODUCTINFO>
            <SERIALNO>0001</SERIALNO>
            <PRODUCTNAME>製品1</PRODUCTNAME>
            <PRICE>500</PRICE>
            <STOCK quantity="10" lineNumber="1">10</STOCK>
        </PRODUCTINFO>
        <PRODUCTINFO>
            <SERIALNO>0002</SERIALNO>
            <PRODUCTNAME>製品2</PRODUCTNAME>
            <PRICE>1000</PRICE>
            <STOCK quantity="20" lineNumber="2">20</STOCK>
        </PRODUCTINFO>
    </DATA>
</ROOT>

<?xml version="1.0" encoding="Shift_JIS"?>
<ROOT>
    <INFO>
        <DATE>2014/01/02</DATE>
        <CUSTOMER>サンプル会社</CUSTOMER>
    </INFO>
    <DATA>
        <PRODUCTINFO>
            <SERIALNO>0003</SERIALNO>
            <PRODUCTNAME>製品3</PRODUCTNAME>
            <PRICE>300</PRICE>
            <STOCK quantity="30" lineNumber="3">30</STOCK>
        </PRODUCTINFO>
        <PRODUCTINFO>
            <SERIALNO>0004</SERIALNO>
            <PRODUCTNAME>製品4</PRODUCTNAME>
            <PRICE>4000</PRICE>
            <STOCK quantity="40" lineNumber="4">40</STOCK>
        </PRODUCTINFO>
    </DATA>
</ROOT>

Option Explicit

Dim myFSO As New FileSystemObject   'FSO　Microsoft Scripting Runtime を参照設定

Dim strPath       As String  'このマクロファイルのパス
Dim strExtName    As String  '拡張子
Dim strFileName() As String  '拡張子がxmlのファイル

Dim intCntF As Integer  'strFileName()の要素数
Dim intY    As Integer  '行方向カウンター
Dim intX    As Integer  '列方向カウンター
Dim i       As Integer  'For用

Sub Sample1()
    
    strPath = ThisWorkbook.Path
    
    intCntF = 0
    ReDim Preserve strFileName(intCntF)
    strFileName(intCntF) = Dir(strPath & "\*.xml")
    
    Do Until strFileName(intCntF) = ""
    
        'ファイルの拡張子を取得
        strExtName = myFSO.GetExtensionName(strPath & "\" & strFileName(intCntF))
        
        If LCase(strExtName) = "xml" Then
        
            intCntF = intCntF + 1
            ReDim Preserve strFileName(intCntF)
                   
        End If
    
        strFileName(intCntF) = Dir()
        
    Loop
    
    
    'Microsoft XML v6.0 を参照設定
    Dim XMLDocument As MSXML2.DOMDocument
    Dim xmlDate     As IXMLDOMNode
    Dim xmlCustomer As IXMLDOMNode
    Dim xmlDataNode As IXMLDOMNode

    'MSXMLオブジェクトを生成し、xmlファイルをロード
    Set XMLDocument = New MSXML2.DOMDocument
    
    'async = False → 読み込み終了後､次の処理をします（同期処理）
    'async = true →だと､読み込みが終わらなくても､次のステップへ（非同期処理）
    'VBAは非同期処理に対応していないので、async = Falseとします
    XMLDocument.async = False
    
    intY = 1
    For i = 0 To UBound(strFileName) - 1
        
        intX = 1  '1列目に戻します
        
        XMLDocument.Load (strPath & "\" & strFileName(i))
        
        If (XMLDocument.parseError.ErrorCode <> 0) Then 'ロード失敗
            
            Dim strMsg As String
            strMsg = XMLDocument.parseError.reason      'エラー内容を出力
            
            MsgBox "ロードに失敗しました・・・" & vbCrLf & vbCrLf & strMsg, vbCritical
            
            Exit Sub
        
        End If
    
        '<INFO>ノードの各情報を取得（検索指定）
        Set xmlDate = XMLDocument.SelectSingleNode("//ROOT/INFO/DATE")
        Set xmlCustomer = XMLDocument.SelectSingleNode("//ROOT/INFO/CUSTOMER")
        
        
        Cells(intY, intX) = xmlDate.Text       '<DATE>情報を出力
        intX = intX + 1
        
        Cells(intY, intX) = xmlCustomer.Text   '<CUSTOMER>情報を出力
        intX = intX + 1
        
        '<DATA>ノードデータを取得
        Set xmlDataNode = XMLDocument.SelectSingleNode("//ROOT/DATA")
    
        '<DATA>ノードの子要素をループで抽出
        Dim Node As IXMLDOMNode
        For Each Node In xmlDataNode.ChildNodes
    
            '<PRODUCTINFO>ノードの子要素を出力
            Cells(intY, intX) = Node.ChildNodes(0).Text  '<SERIALNO>情報を出力
            intX = intX + 1
            
            Cells(intY, intX) = Node.ChildNodes(1).Text  '<PRODUCTNAME>情報を出力
            intX = intX + 1
            
            Cells(intY, intX) = Node.ChildNodes(2).Text  '<PRICE>情報を出力
            intX = intX + 1
            
            Cells(intY, intX) = Node.ChildNodes(3).Text  '<STOCK>情報を出力
            intX = intX + 1
            
            
            '<STOCK quantity="10" lineNumber="1">
            Cells(intY, intX) = Node.ChildNodes(3).Attributes(0).Text  'quantity属性情報を出力
            intX = intX + 1
            
            Cells(intY, intX) = Node.ChildNodes(3).Attributes(1).Text  'lineNumber属性情報を出力
            intX = intX + 1
            
        Next
    
        '各オブジェクトの開放
        If Not xmlDate Is Nothing Then Set xmlDate = Nothing
        If Not xmlCustomer Is Nothing Then Set xmlCustomer = Nothing
        If Not xmlDataNode Is Nothing Then Set xmlDataNode = Nothing
        
        
        intY = intY + 1   '行を下げます
        
    Next
    
    'オブジェクトの開放
    If Not XMLDocument Is Nothing Then Set XMLDocument = Nothing
    
    MsgBox "パース完了！"
    
    End

End Sub