In this example, we do have a large XML file and we want to separate it into several small files. And we always want to copy out a very specific content of this file into individual files. My file looks like this:

(Enlarge Picture)

As you can see by XML-View, there is a pattern recognizable:

(Enlarge Picture)

It’s a large file with the XML of several Trades. As the System is called Calypso, the Trades are separated from the start “<CalypsoTrade>” to the end “<\CalypsoTrade>”. Each trade has an ID which is separated from the start “<TradeId>” to the end “<\TradeId>”.

In the given XML-file are exactly 100 Trades. So target is to have 100 files with the content of each trade.

I tried a code out of the Internet, but this one here did not work. I couldn’t find out why, although I included the corresponding libraries:

EinDatei = "D:\Gesamt.xml"
Von = "<CalypsoTrade>"
Bis = "</CalypsoTrade>"
SuchName = "<TradeId>(.+)</TradeId>"

Set  fso = CreateObject("Scripting.FileSystemObject")
EinOrdner = fso.GetParentFolderName(EinDatei)

set rE = New RegExp
rE.Pattern = SuchName

Inhalt = Split(fso.OpenTextFile(EinDatei).ReadAll, vbCrLF)

For i = 0 To UBound(Inhalt)
    If InStr(Inhalt(i), Von) > 0 Then
        Ausgabe = ""
        AusDatei = ""
        Collect = True
    End If
    If InStr(Inhalt(i), Bis) > 0 Then
        Ausgabe = Ausgabe & Inhalt(i)
        Set GefundenNamen = rE.Execute(Ausgabe)
        For Each GefundenName In GefundenNamen
            AusDatei = GefundenName.SubMatches(0)
        Next
        If AusDatei <> "" Then
            fso.CreateTextFile(EinOrdner & "\" & AusDatei).Write Ausgabe
        Else
            fso.OpenTextFile(EinOrdner & "\" & "Error.txt", 8, 1).Write "Kein Dateiname gefunden in " & vbCrLF & Ausgabe & vbCrLF & vbCrLF
        End If
        Collect = False
    End If
    If Collect Then
        Ausgabe = Ausgabe & Inhalt(i) & vbCrLf
    End If
Next

So I tried my own code which is shown below:

(Enlarge Picture)

Private Sub Split()

    Dim regex As New RegExp
    Dim intLaenge As Long
    Dim Datei As String
    Dim Zusatz As String
    
    Datei = Sheets("Start").Range("C" & 12).Value
    EinDatei = Datei
    Zusatz = Sheets("Start").Range("C" & 14).Value
    Von = "<CalypsoTrade>"
    Bis = "</CalypsoTrade>"
    SuchName = "<TradeId>(.+)</TradeId>"

    Set fso = CreateObject("Scripting.FileSystemObject")
    EinOrdner = fso.GetParentFolderName(EinDatei)

    Set rE = New RegExp
    rE.Pattern = SuchName
    
    Inhalt = fso.OpenTextFile(EinDatei).ReadAll
    intLaenge = Len(Inhalt)
    
    Do While InStr(Inhalt, Von) > 0
            
            Stelle1 = InStr(Inhalt, Von)
            Stelle2 = InStr(Inhalt, Bis)
            Stell = Stelle2 - Stelle1
            
            Dim MyArray As String
            Dim MyArray1 As String
                        
           
                MyArray = Mid(Inhalt, Stelle1, Stell + 15)
                DateiName = "TradeID_" & Mid(Inhalt, Stelle1 + 23, 8) & "_" & Zusatz & ".xml"
                
                fso.CreateTextFile(EinOrdner & "\" & DateiName).Write MyArray
                
                Inhalt = Replace(Inhalt, MyArray, "")
            
    Loop
            
End Sub

As result, you receive this:

(Enlarge Picture)