Import multiple XML files into Excel

Question

I have adapted a VBA code to import all the XML files I have on a folder into Excel. I have tried to run the code with only two files and it takes about 30 seconds. Several minutes to import less than 20 files.

I need to import more than 200,000 files. Can you please help me on how to improve my code?

Sub ListFiles()
'DECLARE AND SET VARIABLEs
Dim ShellApplication As Object
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ShellApplication = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
Path = ShellApplication.self.Path
Set ShellApplication = Nothing
[a3] = "XML"
[b3] = "Files"
'DEFAULT PATH FROM HIDDEN SHEET
Call ListMyFiles(Path, True)
End Sub

Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    'With SearchXML
    Application.ScreenUpdating = False

'--------------------------------------------------------------------
    'FIND XML FILES ONLY, APPLY SEARCH CRIERIA, DISPLAY MATCHES ONLY
    For Each myfile In mySource.Files
        If Right(myfile.Name, 3) = "XML" Or Right(myfile.Name, 3) = "xml" Then 'IS XML?
            LastRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row


 '-------------------------------------------------------------
            'IMPORT XML FILE
            Application.DisplayAlerts = False
            ActiveWorkbook.XmlImport URL:=mySource & "\" & myfile.Name, _
                ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$B$" & LastRow + 1)
            Cells(LastRow + 1, 1) = myfile.Name

'------------------------------------------------------------
            'DELETE MAPS
            maps = ActiveWorkbook.XmlMaps.Count
            For i = 1 To maps
                ActiveWorkbook.XmlMaps(1).Delete
            Next i
        End If
    Next
    If IncludeSubfolders Then 'SEARCH SUBFOLDERS FOR SAME CRITERIA
        For Each MySubFolder In mySource.SubFolders
            Call ListMyFiles(MySubFolder.Path, True)
        Next
    End If
    'End With
    Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("XMLData").UsedRange.WrapText = False
End Sub

Answer 1

Not knowing what your XMl files are like or what you're trying to extract from them, this is mostly speculative:

Generally, you want to strip away as much unwanted data as early as possible in the process. Rather than trying to import an entire file to the worksheet every time, why not strip your document down to a NodeList, and then either target specific nodes (if you're only after certain data) or iterate over them and extract the data values into an array. Then you can print that Array to a worksheet.

I recently built a Tool to extract data from corporate accounts. It loads an XML doc (typically 100kb), parses the Node Tree, searches for specific nodes using XPath, extracts the displayed text of each and sticks it in an array that's printed to a worksheet every 500 lines or so. It grabs 5 sets of nodes from each document, and parses about 1 Million documents/hour, or nearly 300 documents / second.

Below is an extract showing the basic processing of loading, stripping, searching and retrieving.

Public Sub GetDirectorsFromFile(ByVal strFullFilename As String)

    Dim xDoc As MSXML2.DOMDocument
    Set xDoc = New MSXML2.DOMDocument

    Dim colDirectors As Collection
    Set colDirectors = New Collection

    With xDoc

        If .Load(strFullFilename) Then

            .setProperty "SelectionLanguage", "XPath"
            GetDirectorsFromXml xDoc, colDirectors

        End If

    End With

End Sub

Public Sub GetDirectorsFromXml(ByRef xDoc As MSXML2.DOMDocument, ByRef colDirectors As Collection)

    Dim ixItem As Long
    Dim xPathSearchString As String
    Dim nodes As MSXML2.IXMLDOMNodeList
    Dim nodeText As String

        xPathSearchString = "//*[contains(@name,""NameEntityOfficer"")]"
        Set nodes = xDoc.SelectNodes(xPathSearchString )

        For ixItem = 0 To nodes.Length - 1
            nodeText = nodes.Item(ixItem).text
            colDirectors.Add text
        Next ixItem

End Sub