在xml文件中查找值，并将所有相关的TAGS复制到具有VBA的新xml

时间：2017-09-28 14:47:47

标签： xml vba

我有一个xml，我想搜索一个特定值，然后将与该值相关的所有TAGS复制到另一个xml。

这是xml的一个例子：

<?xml version="1.0" encoding="utf-8"?> 
<FlussoMisure xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" 
CodFlusso="PDO"> 
 <IdentificativiFlusso> 
  <PIvaUtente>00000000000</PIvaUtente> 
  <PIvaDistributore>00000000000</PIvaDistributore> 
  <CodContrDisp>000000</CodContrDisp> 
 </IdentificativiFlusso>
<DatiPod>
  <Pod>IT001E00000001</Pod>
  <MeseAnno>08/2017</MeseAnno>
  <DatiPdp>
    <PuntoDispacciamento>NORD</PuntoDispacciamento>
    <Trattamento>O</Trattamento>
    <Tensione>15000</Tensione>
    <PotContrImp>200,000</PotContrImp>
    <PotDisp>200,000</PotDisp>
  </DatiPdp>
  <Curva>
    <Raccolta>P</Raccolta>
    <TipoDato>E</TipoDato>
    <Validato>S</Validato>
    <PotMax>96,264</PotMax>
    <Ea E1="1,590" E2="1,560">01</Ea>
    <Er E1="0,660" E2="0,660">31</Er>
  </Curva>
</DatiPod>
</DatiPod>
<DatiPod>
  <Pod>IT001E00000002</Pod>
  <MeseAnno>08/2017</MeseAnno>
  <DatiPdp>
    <PuntoDispacciamento>NORD</PuntoDispacciamento>
    <Trattamento>O</Trattamento>
    <Tensione>15000</Tensione>
    <PotContrImp>138,000</PotContrImp>
    <PotDisp>138,000</PotDisp>
  </DatiPdp>
  <Curva>
    <Raccolta>T</Raccolta>
    <TipoDato>E</TipoDato>
    <Validato>S</Validato>
    <PotMax>153,600</PotMax>
    <Ea E1="1,590" E2="1,560">01</Ea>
    <Er E1="0,660" E2="0,660">31</Er>
  </Curva>
</DatiPod>
</FlussoMisure>

我想要做的是搜索TAG Pod中包含的值，并生成一个相同的xml，只有一个POD记录，这里是输出我想要搜索值＆＃ 34; IT001E00000002＆＃34;：

<?xml version="1.0" encoding="utf-8"?> 
<FlussoMisure xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" CodFlusso="PDO"> 
 <IdentificativiFlusso> 
  <PIvaUtente>00000000000</PIvaUtente> 
  <PIvaDistributore>00000000000</PIvaDistributore> 
  <CodContrDisp>000000</CodContrDisp> 
 </IdentificativiFlusso>
<DatiPod>
  <Pod>IT001E00000002</Pod>
  <MeseAnno>08/2017</MeseAnno>
  <DatiPdp>
    <PuntoDispacciamento>NORD</PuntoDispacciamento>
    <Trattamento>O</Trattamento>
    <Tensione>15000</Tensione>
    <PotContrImp>138,000</PotContrImp>
    <PotDisp>138,000</PotDisp>
  </DatiPdp>
  <Curva>
    <Raccolta>T</Raccolta>
    <TipoDato>E</TipoDato>
    <Validato>S</Validato>
    <PotMax>153,600</PotMax>
    <Ea E1="1,590" E2="1,560">01</Ea>
    <Er E1="0,660" E2="0,660">31</Er>
  </Curva>
</DatiPod>
</FlussoMisure>

有人能帮助我吗？

提前致谢，

安德烈

2 个答案:

答案 0 :(得分：0)

实际上，请考虑XPath的兄弟XSLT，用于转换整个XML文档。具体来说，您可以运行Identity Transform以删除与搜索条件不匹配的所有其他<DatiPod>个节点。在VBA中，您可以使用MSXML库来运行XSLT 1.0脚本，甚至可以从字符串动态构建XSLT以传入搜索项：

<强> VBA 

Option Explicit

Sub XSLTransform()
On Error GoTo ErrHandle
    ' ENABLE REFERENCE: Microsoft XML v, #.#
    Dim xmlDoc As New MSXML2.DOMDocument, xslDoc As New MSXML2.DOMDocument, newDoc As New MSXML2.DOMDocument

    ' LOAD XML AND XSL FILES
    xmlDoc.async = False
    xmlDoc.Load "C:\Path\To\Input.xml"

    xslDoc.async = False
    xslDoc.LoadXML DynamicXSLT("IT001E00000002")  '<------ PASS SEARCH ITEM

    ' TRANSFORM XML
    xmlDoc.transformNodeToObject xslDoc, newDoc
    newDoc.Save "C:\Path\To\Output.xml"

    MsgBox "Successfully transformed XML!", vbInformation
    Exit Sub

ExitHandle:
    Set xmldoc = Nothing: Set xslDoc = Nothing: Set newDoc = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Err.Raise xslDoc.parseError.ErrorCode, , xslDoc.parseError.reason
    Resume ExitHandle

End Sub

Function DynamicXSLT(searchpod As String) As String
    Dim xslstr As String

    xslstr = " <xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" _
                & "   <xsl:output indent=""yes"" method=""xml"" encoding=""UTF-8"" />" _
                & "   <xsl:strip-space elements=""*""/>" _
                & " " _
                & "   <xsl:param name=""param1""/>" _
                & " " _
                & "   <xsl:template match=""@*|node()"">" _
                & "     <xsl:copy>" _
                & "       <xsl:apply-templates select=""@*|node()""/>" _
                & "     </xsl:copy>" _
                & "   </xsl:template>" _
                & " " _
                & "  <!-- REMOVE ALL OTEHR PODS -->" _
                & "   <xsl:template match=""DatiPod[Pod!='" & searchpod & "']"">" _
                & "   </xsl:template>" _
                & " " _
                & " </xsl:stylesheet>"

    DynamicXSLT = xslstr

End Function

<强>输出 

<?xml version="1.0" encoding="UTF-8"?>
<FlussoMisure CodFlusso="PDO" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
    <IdentificativiFlusso>
        <PIvaUtente>00000000000</PIvaUtente>
        <PIvaDistributore>00000000000</PIvaDistributore>
        <CodContrDisp>000000</CodContrDisp>
    </IdentificativiFlusso>
    <DatiPod>
        <Pod>IT001E00000002</Pod>
        <MeseAnno>08/2017</MeseAnno>
        <DatiPdp>
            <PuntoDispacciamento>NORD</PuntoDispacciamento>
            <Trattamento>O</Trattamento>
            <Tensione>15000</Tensione>
            <PotContrImp>138,000</PotContrImp>
            <PotDisp>138,000</PotDisp>
        </DatiPdp>
        <Curva>
            <Raccolta>T</Raccolta>
            <TipoDato>E</TipoDato>
            <Validato>S</Validato>
            <PotMax>153,600</PotMax>
            <Ea E1="1,590" E2="1,560">01</Ea>
            <Er E1="0,660" E2="0,660">31</Er>
        </Curva>
    </DatiPod>
</FlussoMisure>

答案 1 :(得分：0)

等等，我设法自己添加所需的编码来纠正它：
 ＆安培; ＆＃34; ＆＃34; _

这是完整的代码：

Option Explicit

Sub XSLTransform() On Error GoTo ErrHandle
    ' ENABLE REFERENCE: Microsoft XML v, #.#
    Dim xmlDoc As New MSXML2.DOMDocument, xslDoc As New MSXML2.DOMDocument, newDoc As New MSXML2.DOMDocument
    Dim LResult As String

    ' LOAD XML AND XSL FILES
    xmlDoc.async = False
    xmlDoc.Load "C:\XML_Cutter\Input.xml"

    xslDoc.async = False
    xslDoc.LoadXML DynamicXSLT("IT001E04153430")  '<------ PASS SEARCH ITEM

    ' TRANSFORM XML
    xmlDoc.transformNodeToObject xslDoc, newDoc

    newDoc.Save "C:\XML_Cutter\Output.xml"

    MsgBox "Successfully transformed XML!", vbInformation
    Exit Sub

ExitHandle:
    Set xmlDoc = Nothing: Set xslDoc = Nothing: Set newDoc = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Err.Raise xslDoc.parseError.ErrorCode, , xslDoc.parseError.reason
    Resume ExitHandle

End Sub

Function DynamicXSLT(searchpod As String) As String
    Dim xslstr As String

    xslstr = " <xsl:stylesheet version=""1.0"" xmlns:xsl=""http://www.w3.org/1999/XSL/Transform"">" _
                & "   <xsl:output indent=""yes"" encoding=""UTF-8"" method=""xml"" />" _
                & "   <xsl:strip-space elements=""*""/>" _
                & " " _
                & "   <xsl:param name=""param1""/>" _
                & " " _
                & "   <xsl:template match=""@*|node()"">" _
                & "     <xsl:copy>" _
                & "       <xsl:apply-templates select=""@*|node()""/>" _
                & "     </xsl:copy>" _
                & "   </xsl:template>" _
                & " " _
                & "  <!-- REMOVE ALL OTEHR PODS -->" _
                & "   <xsl:template match=""DatiPod[Pod!='" & searchpod & "']"">" _
                & "   </xsl:template>" _
                & " " _
                & " </xsl:stylesheet>"

    DynamicXSLT = xslstr

End Function

非常感谢Parfait，你非常善良！

安德烈

相关问题
最新问题