从多个 XML 文件中读取数据的自动化

Question

I've been trying to improve my code for a while now, but I can't get any further on my own.

I have a function that is executed via button press. As it is, it only works with one file.

In the best case I could click a folder and the function would loop through the subfolders and read all XML files from all subfolders and would then enter the desired words in a table.

It would help me if I could read multiple XML files from a subfolder and not just one. Maybe then I can get further and get the other part right by myself.

This is my code so far:

Private Sub CommandButtonImport_Click()
    Dim fd As Office.FileDialog                     
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Title = "Select a XML File"
        .AllowMultiSelect = True             
            
        If .Show = True Then
            xmlFileName = .SelectedItems(1)

            Dim xDoc As Object
            Set xDoc = CreateObject("MSXML2.DOMDocument")
            xDoc.async = False: xDoc.ValidateOnParse = False
            xDoc.Load (xmlFileName)

            Set Products = xDoc.DocumentElement
            row_number = 1
            
            Rows("11:11").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
            
            For Each Product In Products.ChildNodes
                Range("C11").Value = Products.ChildNodes(0).ChildNodes(0).Attributes.Item(21).Value
                Range("F11").Value = Products.ChildNodes(0).ChildNodes(0).Attributes.Item(0).Value
                Range("G11").Value = Products.ChildNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).Attributes.Item(1).Value
                Range("C:C").Columns.AutoFit 
    
                row_number = row_number + 1
            Next Product            
        End If
    End With
    
    Add_Row_Number
End Sub 

I am not sure but this might Help

Any input can help and I would be very grateful thanks in advance RomanWASD

Answer 1

Use the getFolder method of a FileSystemObject to create a folder object. Then use Subfolders property and Files property in a recursive manner.

Option Explicit

Private Sub CommandButtonImport_Click()
    
    Dim fd As Office.FileDialog, folder As String, n As Long
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Filters.Clear
        .Title = "Select a Folder"
        .AllowMultiSelect = True
            
        If .Show = True Then
            folder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Dim fso As Object, ws As Worksheet, t0 As Single: t0 = Timer
    Set ws = ActiveSheet ' or better as Thisworkbook.Sheets("Name")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' recurse down folder tree
    n = n + ScanFolder(ws, fso.GetFolder(folder))
    ws.Range("C:C").Columns.AutoFit
    MsgBox n & " files scanned", vbInformation, Format(Timer - t0, "0.0 secs")
    
End Sub

Function ScanFolder(ws As Worksheet, folder As Object) As Long
    
    Dim subfolder As Object, file As Object, n As Long
    For Each subfolder In folder.SubFolders
        n = n + ScanFolder(ws, subfolder) ' recurse
    Next
   
    For Each file In folder.Files
        If file.Type = "XML Document" Then
            ParseFile ws, file
            n = n + 1
        End If
    Next
    ScanFolder = n ' number of files
    
End Function

Function ParseFile(ws As Worksheet, file As Object)

    Dim xDoc As Object, Products As Object
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    
    With xDoc
        .async = False
        .ValidateOnParse = False
        .Load file.Path 'folder and filename
        Set Products = .DocumentElement
    End With
    
    If Products Is Nothing Then
    Else
        ws.Rows("11:11").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
        With Products.ChildNodes(0).ChildNodes(0)
            ws.Range("C11").Value = .Attributes(21).NodeValue
            ws.Range("F11").Value = .Attributes(0).NodeValue
            ws.Range("G11").Value = .ChildNodes(1).ChildNodes(0).Attributes(1).NodeValue
        End With
    End If

End Function

Answer 2

I was recently dealing with a similar problem. The fastest solution I tried was to use import XML in VBA, import it as table and load table into array.

Sub xmlintoarray()
Dim FSO As Object
Dim FSOfile As Object
Dim wb As Workbook
Dim path As String

path = "C:\Documents\Studypool"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOfile = FSO.GetFolder(path)
Set FSOfile = FSOfile.Files
Set wb = ThisWorkbook
For Each FSOfile In FSOfile

wb.Sheets.Add.Name = FSOfile.Name

wb.XmlImport FSOfile.path, Importmap:=Nothing, overwrite:=True, _
Destination:=ThisWorkbook.Sheets(FSOfile.Name).Range("$A$1")

Next

'here insert code to merge tables
'create array from merged table
'or create merge arrays together.

End Sub