VBA XML-读取和遍历XML文件的2个不同分支

时间:2019-06-17 19:16:46

标签: xml vba

我进行了搜索,测试和阅读,但听不懂。请考虑以下XML文件:

对于每个“元素”,我尝试从分支中提取“ date *”,并从分支中提取文本“ some text”。结果应以Excel的形式给出(单元格之后的单元格):date1,some_text1,some_text2,some_text3, some_text4,some_text5,some_text6。然后,下一行:date2,some_text7,some_text8,some_text9,some_text10,some_text11,some_text12(等等)

<Tree>

  <Element ID="1">
    <Head>
      <Created>date1</Created>
    </Head>
    <Body>
      <Version Nr="1">
        <Signal ID="878465">
          <Text1>some_text1</Text1>
          <Text2>some_text2</Text2>
          <Text3>some_text3</Text3>
        </Signal>
        <Signal ID="2654647">
          <Text1>some_text4</Text1>
          <Text2>some_text5</Text2>
          <Text3>some_text6</Text3>
        </Signal>
      </Version>
    </Body>
  </Element>

  <Element ID="2">
    <Head>
      <Created>date2</Created>
    </Head>
    <Body>
      <Version Nr="2">
        <Signal ID="48554568">
          <Text1>some_text7</Text1>
          <Text2>some_text8</Text2>
          <Text3>some_text9</Text3>
        </Signal>
        <Signal ID="89243565">
          <Text1>some_text10</Text1>
          <Text2>some_text11</Text2>
          <Text3>some_text12</Text3>
        </Signal>
      </Version>
    </Body>
  </Element>

  <Element ID="3">
    <Head>
      <Created>date3</Created>
    </Head>
    <Body>
      <Version Nr="3">
        <Signal ID="34547856">
          <Text1>some_text13</Text1>
          <Text2>some_text14</Text2>
          <Text3>some_text15</Text3>
        </Signal>
        <Signal ID="34634567">
          <Text1>some_text16</Text1>
          <Text2>some_text17</Text2>
          <Text3>some_text18</Text3>
        </Signal>
      </Version>
    </Body>
  </Element>

</Tree>

要么无法正确循环,要么始终仅显示第一个节点的值。

我的代码看起来像这样(尽管我尝试了几种变体):

Sub test1

Dim XDoc As MSXML2.DOMDocument
Dim Entry, Thing As Object
Dim Created, Version_Nr, Text1, Text2, Text3 As String

Set XDoc = New MSXML2.DOMDocument
XDoc.async = False
XDoc.validateOnParse = True
XDoc.Load("C:\MyXML.xml")

Set Entry = XDoc.SelectNodes("//Tree/Element")
    For Each Thing In Entry
        Created = Thing.SelectSingleNode(".//Created").Text
        'write Created in a cell

         Version_Nr = Thing.SelectSingleNode(".//Body/Version").Attributes.getNamedItem("Nr").Text
         'write Version_Nr in a cell 

         Text1 = Thing.SelectSingleNode(".//Text1").Text
         Text2 = Thing.SelectSingleNode(".//Text2").Text
         Text3 = Thing.SelectSingleNode(".//Text3").Text
         'write the Text1, Text2, Text3 (which shall contain some_text1, some_text2, some_text3) in cells
    Next Thing

    Set XDoc = Nothing   

End sub

我实际上也在考虑这样的事情(一个循环i表示“元素”,一个循环j表示“ Text1”,“ Text2”等),并在循环中使用version_nr作为变量-但这代码是完全是越野车:

Sub test2

Dim XDoc As MSXML2.DOMDocument
Dim Entry As Object
Dim i, j As Integer
Dim Created, Version_Nr, Text1, Text2, Text3 As String

Set XDoc = New MSXML2.DOMDocument
XDoc.async = False
XDoc.validateOnParse = True
XDoc.Load("C:\MyXML.xml")

Set Entry = XDoc.SelectNodes("//Tree/Element")
    For i = 1 To Entry.Length
        Created = XDoc.SelectSingleNode(".//Created").Text
        For j = 1 To Entry(i).ChildNodes.Length
           Version_Nr = Entry.SelectSingleNode(".//Body/Version").Attributes.getNamedItem("Nr").Text
           Text1 = Entry.SelectSingleNode(".//Text1").Text
           Text2 = Entry.SelectSingleNode(".//Text2").Text
           Text3 = Entry.SelectSingleNode(".//Text3").Text
        Next j
    Next i

    Set XDoc = Nothing   

End sub

有人在同时在“元素”之后访问“日期”和“ some_text”值“元素”的想法很好吗?

谢谢!


编辑1 更正了一些错字,错误的XML(对不起...)并添加了完整的VBA代码

编辑2 非常感谢大家-您的回答如此之快。太棒了!

1 个答案:

答案 0 :(得分:1)

更新:

Sub ProcessXML()

    '// Tools -> References -> Microsoft XML, v6.0
    Dim r As Long, c As Integer
    Dim doc As New MSXML2.DOMDocument60
    Dim element_nodes As MSXML2.IXMLDOMNodeList
    Dim element_node As MSXML2.IXMLDOMNode
    Dim signal_node As MSXML2.IXMLDOMNode
    Dim text_node As MSXML2.IXMLDOMNode

    doc.Load "PATH_TO_FILE"

    With doc.parseError
        If .ErrorCode <> 0 Then
            MsgBox "XML parsing error: " & .reason & Chr(10) & "at: " & .srcText
            Exit Sub
        End If
    End With

    Set element_nodes = doc.SelectNodes("/Tree/Element")
    For Each element_node In element_nodes
        r = r + 1: c = 1
        Cells(r, "A") = element_node.SelectSingleNode("Head/Created").Text
        For Each signal_node In element_node.SelectNodes("Body/Version/Signal")
            For Each text_node In signal_node.ChildNodes
                c = c + 1: Cells(r, c) = text_node.Text
            Next
        Next
    Next

End Sub