從多個 XML 文件中讀取數據的自動化

Question

一段時間以來，我一直在嘗試改進我的代碼，但我無法靠自己取得任何進展。

我有一個通過按下按鈕執行的 function。 事實上，它只適用於一個文件。

在最好的情況下，我可以單擊一個文件夾，function 將遍歷子文件夾並從所有子文件夾中讀取所有 XML 文件，然后在表格中輸入所需的單詞。

如果我可以從一個子文件夾而不是一個文件夾中讀取多個 XML 文件，那將對我有所幫助。 也許那時我可以走得更遠，自己把另一部分做好。

到目前為止，這是我的代碼：

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 

我不確定，但這可能會有所幫助

任何輸入都可以提供幫助，我將非常感謝提前感謝 RomanWASD

Answer 1

使用FileSystemObject的getFolder方法創建文件夾 object。 然后以遞歸方式使用Subfolders屬性和Files屬性。

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

我最近正在處理一個類似的問題。 我嘗試過的最快的解決方案是在 VBA 中使用 import XML，將其作為表導入並將表加載到數組中。

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