【Excel 】【VBA】XMLファイル作成とファイル出力

http://www.openreference.org/articles/view/651

www.openreference.org

上記サイトのコードがすごく役に立ちました。ありがとうございます。

今、自分のExcelのバージョンでは、”DOMDocument60”が最新

MSXML2.DOMDocument だとエラーがでたので修正しました。

それから、エラー処理を好み（FINALLY句バージョン）にさせてもらいました。

これをベースに勉強させてもらいます！

Public Sub sample()
    Dim strArray() As Variant
    'Micro
    Dim XMLDocument As MSXML2.DOMDocument60
    Dim xmlRoot As IXMLDOMNode
    Dim xmlData As IXMLDOMNode
    Dim xmlChildData As IXMLDOMNode
    Dim xmlAttr As MSXML2.IXMLDOMAttribute

    '出力するデータを設定
    strArray = Array(Array("てすと太郎", "東京都港区XX-XX-XX", "111-1111-1111"), _
                     Array("てすと次郎", "埼玉県さいたま市XX-XX-XX", "222-2222-2222"), _
                     Array("てすと三郎", "神奈川県横浜市XX-XX-XX", "333-3333-3333"))

On Error GoTo ERROR_

    'MSXMLオブジェクトを生成
    Set XMLDocument = New MSXML2.DOMDocument60

    'XML宣言を生成
    Call XMLDocument.appendChild(XMLDocument.createProcessingInstruction("xml", "version=""1.0"" encoding=""Shift_JIS"""))

    '要素を生成
    Set xmlRoot = XMLDocument.appendChild(XMLDocument.createElement("ROOT"))

    '配列データの数だけ要素を要素に追加
    Dim intId As Integer
    For intId = 0 To UBound(strArray)

        '要素を生成
        Set xmlData = XMLDocument.createElement("DATA")  '要素を生成
        Set xmlAttr = XMLDocument.createAttribute("id")  'id属性を生成
        xmlAttr.NodeValue = intId + 1                    'id属性の値を設定
        Call xmlData.Attributes.setNamedItem(xmlAttr)    '要素にid属性を設定

        '要素の子要素を生成して要素に追加
        Set xmlChildData = xmlData.appendChild(XMLDocument.createElement("Name"))
        xmlChildData.Text = strArray(intId)(0)
        Set xmlChildData = xmlData.appendChild(XMLDocument.createElement("Address"))
        xmlChildData.Text = strArray(intId)(1)
        Set xmlChildData = xmlData.appendChild(XMLDocument.createElement("Tel"))
        xmlChildData.Text = strArray(intId)(2)

        '要素を要素に追加
        Call xmlRoot.appendChild(xmlData)
    Next intId

    'XMLドキュメントを出力
    XMLDocument.Save ("C:\Users\Public\Desktop\sample.html")
    
    
        
FINALLY:
    '各オブジェクトの開放
    If Not XMLDocument Is Nothing Then Set XMLDocument = Nothing
    If Not xmlRoot Is Nothing Then Set xmlRoot = Nothing
    If Not xmlData Is Nothing Then Set xmlData = Nothing
    If Not xmlChildData Is Nothing Then Set xmlChildData = Nothing
    If Not xmlAttr Is Nothing Then Set xmlAttr = Nothing
    
    Exit Sub


ERROR_:
    MsgBox Err.Description
    GoTo FINALLY
End Sub