Remove the root tag of the XML but keep the contents inside it

Question

I am using the below code to enable the user to select an XML file, and then the code deletes the <metadata> tag from the XML, and replaces it by the modified one;

Sub Button1_Click()
    Dim fso As Object, ts As Object, doc As Object
    Dim data As Object, filename As String
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' select file
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        filename = .SelectedItems(1)
    End With
    
    ' read file and add top level
    Set doc = CreateObject("MSXML2.DOMDocument.6.0")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpentextFile(filename)
    doc.LoadXML Replace(ts.readall, "<metadata>", "<root><metadata>", 1, 1) & "</root>" '<metadata> removed
    ts.Close
    
    ' import data tag only
    Dim s As String
    Set data = doc.getElementsByTagName("data")(0)
    s = data.XML
    ' MsgBox s
    
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write s
    ts.Close
    
    MsgBox s 'works perfectly
End Sub

The above code worked perfectly for me, when I was assigned to work with an XML like this -

But now, I have a different XML to deal with, which is like - (difference : the ajson root tag)

How do I delete the ajson opening and closing tags, so I get my desired result? Kindly guide... Thanks!

Answer 1

Here is how to do it via XSLT transformation.

XSLT in VBA: Excel VBA Coding for xls transformation

Input XML

<?xml version="1.0"?>
<ajson:json xmlns:ajson="http://www.google.com">
    <metadata>
        <sample>Hi</sample>
    </metadata>
    <data>
        <catalog>
            <book id="bk101">
                <author>Gambardella, Matthew</author>
                <title>XML Developer's Guide</title>
            </book>
        </catalog>
    </data>
</ajson:json>

XSLT

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

    <!-- template to copy without a namespace-->
    <xsl:template match="*">
        <xsl:element name="{local-name()}">
            <xsl:copy-of select="@*"/>
            <xsl:apply-templates/>
        </xsl:element>
    </xsl:template>

    <!-- template to remove document's root element -->
    <xsl:template match="/*">
        <xsl:apply-templates select="node()"/>
    </xsl:template>

    <xsl:template match="data" mode="copy-no-namespaces">
        <xsl:copy>
            <xsl:apply-templates select="@*|node()"/>
        </xsl:copy>
    </xsl:template>

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

Output XML

<data>
  <catalog>
    <book id="bk101">
      <author>Gambardella, Matthew</author>
      <title>XML Developer's Guide</title>
    </book>
  </catalog>
</data>

Answer 2

Since your XML format seems to be variable maybe a simple text processing script is all you need.

Option Explicit

Sub Button1_Click()
    Dim fso As Object, ts As Object, filename As String
    Dim s As String, sOut As String, bData As Boolean
    
    'select file
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        filename = .SelectedItems(1)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpentextFile(filename)
   
    ' capture between <data> .... </data>
    Do While ts.AtEndOfStream <> True
        s = ts.readline
        If Trim(s) = "<data>" Then bData = True
        If bData Then sOut = sOut & s & vbCrLf
        If Trim(s) = "</data>" Then bData = False
    Loop
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write sOut
    ts.Close
    MsgBox sOut
    
End Sub

Answer 3

Here's how you would do that in VBA using the MSXML objects :

Sub Example()
    Dim myDoc As New MSXML2.DOMDocument60
    myDoc.LoadXML Sheet1.[A1].Value
    'myDoc now contains the example XML from your post
    Set myDoc = SetNewRoot(myDoc, "data")
    'MyDoc's root has now changed to data, all other nodes & elements are discarded.
End Sub

Function SetNewRoot(XMLDoc As MSXML2.DOMDocument60, TagName As String) As MSXML2.DOMDocument60
    Dim newDoc As New MSXML2.DOMDocument60
    Dim nodeSelect As IXMLDOMSelection
    Set nodeSelect = XMLDoc.getElementsByTagName(TagName)
    If nodeSelect.Length = 0 Then
        Set SetNewRoot = Nothing
    Else
        Dim newRoot As IXMLDOMNode
        Set newRoot = nodeSelect(0).CloneNode(deep:=True)
        newDoc.appendChild newRoot
        Set SetNewRoot = newDoc
    End If
End Function

This code uses the Microsoft XML, v6.0 reference, add that to your project to be able to use these objects. To add the reference automatically, use the following code:

Private Sub AddXMLRef()
    AddExcelRef ThisWorkbook, "{F5078F18-C551-11D3-89B9-0000F81FE221}", "MSXML2"
End Sub
Private Sub AddExcelRef(wbk As Workbook, sGuid As String, sRefName As String)
    Dim i As Integer
    On Error GoTo EH
    With wbk.VBProject.References
        For i = 1 To .Count
            If .Item(i).Name = sRefName Then
               Exit For
            End If
        Next i
        If i > .Count Then
           .AddFromGuid sGuid, 0, 0 ' 0,0 should pick the latest version installed on the computer
        End If
    End With
Exit Sub
EH:
    MsgBox "Error in 'AddRef'" & vbCrLf & vbCrLf & Err.Description
End Sub