Удаление дочернего узла XML с помощью VBA

Вам необходимо предварительно обработать XML-файл с помощью преобразования XSLT перед его загрузкой/импортом.

В приведенном ниже XSLT используется так называемый шаблон преобразования идентичности.

Одна единственная строка <xsl:template match = "is_summary"/> предотвращает появление этого XML-элемента в выходном XML-файле.

XSLT

<?xml version='1.0'?>
<xsl:stylesheet version = "1.0" xmlns:xsl = "http://www.w3.org/1999/XSL/Transform">
   <xsl:output method = "xml" omit-xml-declaration = "no"
               encoding = "UTF-8" indent = "yes"/>
   <xsl:strip-space elements = "*"/>

   <!--Identity transform-->
   <xsl:template match = "@*|node()">
      <xsl:copy>
         <xsl:apply-templates select = "@*|node()"/>
      </xsl:copy>
   </xsl:template>

   <xsl:template match = "is_summary"/>
</xsl:stylesheet>

ВБА

Private Sub Transform(sourceFile, stylesheetFile, resultFile)

    Dim source As New MSXML2.DOMDocument60
    Dim stylesheet As New MSXML2.DOMDocument60
    Dim result As New MSXML2.DOMDocument60

    ' Load data.
    source.async = False
    source.Load sourceFile

    ' Load style sheet.
    stylesheet.async = False
    stylesheet.Load stylesheetFile

    If (source.parseError.ErrorCode <> 0) Then
       MsgBox ("Error loading source document: " & source.parseError.reason)
    Else
        If (stylesheet.parseError.ErrorCode <> 0) Then
            MsgBox ("Error loading stylesheet document: " & stylesheet.parseError.reason)
        Else
            ' Do the transform.
            source.transformNodeToObject stylesheet, result
            result.Save resultFile
        End If
    End If

End Sub

Пожалуйста, попробуйте следующий способ:

Sub testRemoveXMLNode()
   'it needs a reference to 'Microsoft XML, v6.0'
   Dim xmlPath As String, XDoc As MSXML2.DOMDocument60, n As MSXML2.IXMLDOMNode
   
   xmlPath = "Your XML file full name" 'use the real name
   Set XDoc = New MSXML2.DOMDocument60
   XDoc.Load (xmlPath)
   Debug.Print XDoc.XML & vbCrLf & "___"
    Dim strTag As String: strTag = "is_summary"
    
    For Each n In XDoc.DocumentElement.ChildNodes
        recursiveTagSrc n, strTag
    Next n

    Debug.Print XDoc.XML 'just to see the result
    'it can be saved as another XML document or overwrite the original XML file (xDoc.Save xmlPath)...
End Sub
Sub recursiveTagSrc(n As MSXML2.IXMLDOMNode, strTag As String)
    Dim Nd As MSXML2.IXMLDOMNode
    If n.HasChildNodes Then
        For Each Nd In n.ChildNodes
            If Nd.HasChildNodes Then recursiveTagSrc Nd, strTag
            If Nd.nodeName = strTag Then
                n.RemoveChild Nd
            End If
        Next Nd
    End If
End Sub

Следующая функция демонстрирует альтернативу XMLDOM рабочему решению @FaneDuru.

• извлечение списка узлов, включающего только соответствующие узлы, с помощью простого выражения XPath (здесь: «//is_summary», где двойные косые черты указывают на поиск на любом уровне иерархии - см. раздел b) и путем
• удаление этих результатов напрямую с помощью метода RemoveChild (см. раздел c)

вместо того, чтобы проходить все узлы один за другим, тем самым сводя к минимуму проверки, удалять или нет.

Примечание:

Действительный подход @Ицхака-Хабинского для удаления использует не методы XMLDOM, а XSLT, язык специального назначения, предназначенный для преобразования исходных XML-файлов (в данном случае путем удаления узлов посредством преобразования идентичности) в соответствии с различными критериями.

Function cleanXML(ByVal xmlFilename As String, _
    ByVal DELNODE As String) _
    As MSXML2.DOMDocument60
'a) load src
    Dim xDoc As MSXML2.DOMDocument60
    Set xDoc = New MSXML2.DOMDocument60
    xDoc.async = False
    xDoc.Load xmlFilename
'b) get nodelist
    Dim nodes As MSXML2.IXMLDOMNodeList
    Set nodes = xDoc.SelectNodes("//" & DELNODE)
'c) remove each node nodelist
    Dim node As MSXML2.IXMLDOMNode
    For Each node In nodes
        node.ParentNode.RemoveChild node
    Next
'd) return xml as object
    Set cleanXML = xDoc
End Function

Пример звонка

Sub ExampleCall()
    Dim t As Double: t = Timer
'0) initial definitions
    Const DELNODE As String = "is_summary"
    Dim fn As String: fn = ThisWorkbook.Path & "\xml\" & "Whatever.xml"
'1) get result with removed DELNODEs
    Dim result As MSXML2.DOMDocument60
    Set result = cleanXML(fn, DELNODE)
'2) display result
    Debug.Print result.xml
    Debug.Print Format(Timer - t, "0.0 secs needed")
    
''3) save result to any destination filename
'    Dim destFn As String: destFn = fn  ' e.g. overwrite src
'    result.Save destFn
End Sub