Как загрузить все файлы XML из подпапок с помощью Excel VBA?

Question

В настоящее время я использую код Excel VBA для импорта определенных узлов из файла XML в электронную таблицу Excel.Файлы хранятся по дням в отдельных папках.После того, как работа выполнена, обычно через 20+ дней, у меня есть все файлы из подпапок, используя код VBA ниже:

Private Sub Create_Heading()
    ' This subroutine creates the necessary headings in the specified cells.

    Range("A1").Value = "Bead No."
    Range("B1").Value = "Duration (s)"
    Range("C1").Value = "Log #"
    Range("D1").Value = "Sched. ID"
    Range("E1").Value = "System ID"

    Range("A1:E1").WrapText = True
    Range("A1:A2").Merge
    Range("B1:B2").Merge
    Range("C1:C2").Merge
    Range("D1:D2").Merge
    Range("E1:E2").Merge


    Range("F2").Value = "Peak Current"
    Range("G2").Value = "Back Current"
    Range("H2").Value = "Peak Voltage"
    Range("I2").Value = "Back Voltage"
    Range("J2").Value = "Peak Travel Speed"
    Range("K2").Value = "Back Travel Speed"
    Range("L2").Value = "Peak Wire Speed"
    Range("M2").Value = "Back Wire Speed"

    Range("F1:M1").Merge
    Range("F1").Value = "Set"

    Range("N2").Value = "Peak Current"
    Range("O2").Value = "Back Current"
    Range("P2").Value = "Peak Voltage"
    Range("Q2").Value = "Back Voltage"
    Range("R2").Value = "Peak Travel Speed"
    Range("S2").Value = "Back Travel Speed"
    Range("T2").Value = "Peak Wire Speed"
    Range("U2").Value = "Back Wire Speed"

    Range("N1:U1").Merge
    Range("N1").Value = "Actual"

    Range("V2").Value = "Date (DD/MM/YY)"
    Range("W2").Value = "Start (hh:mm:ss)"
    Range("X2").Value = "End (hh:mm:ss)"
    Range("Y2").Value = "Duration (hh:mm:ss)"
    Range("Z2").Value = "Waiting Time (hh:mm:ss)"

    Range("V1:Z1").Merge
    Range("V1").Value = "Timeline"


    Range("A1:Z2").HorizontalAlignment = xlCenter
    Range("A1:Z2").VerticalAlignment = xlCenter
    Range("A1:Z2").Font.Bold = True

    Range("A1").ColumnWidth = 5
    Range("B1:E1").ColumnWidth = 8
    Range("F1:U1").ColumnWidth = 9
    Range("V1:Z1").ColumnWidth = 14

    Range("F2:Z2").WrapText = True

    ActiveSheet.Columns("V").NumberFormat = "dd/mm/yy"
    ActiveSheet.Columns("W").NumberFormat = "hh:mm:ss"
    ActiveSheet.Columns("X").NumberFormat = "hh:mm:ss"
    ActiveSheet.Columns("Y").NumberFormat = "hh:mm:ss"
    ActiveSheet.Columns("Z").NumberFormat = "hh:mm:ss"

End Sub


Sub XMLProcessing_rev0()
    Dim StrFile As String
    Dim Address As String
    Dim i As Integer
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    Application.StatusBar = "Initializing..."

    ' Check if heading area is empty, if so create headings.
    If WorksheetFunction.CountA(Range("A1:Z2")) = 0 Then
        Create_Heading
    End If

    ' Prompt user to enter the file location
    Address = InputBox("Enter folder location of data files:", "Welding Parameter XML Processing") & "\"
    ' Macro will look for files that satisfy the path: "UserAddress\LOG*"  i.e. LOG____.xml files
    StrFile = dir(Address & "LOG*")

    i = 0
    ' This loop runs for every file in the folder
    Do While Len(StrFile) > 0
        Application.StatusBar = "Copying row " & i + 1 & "."

        ' Load the XML document
        xmlDoc.Load (Address & StrFile)

        ' Set values in worksheet to data found in XML

        Cells(3 + i, 1).Value = xmlDoc.SelectSingleNode("//log").getAttribute("weld")
        Cells(3 + i, 2).Value = xmlDoc.SelectSingleNode("//data/totaltime").Text
        Cells(3 + i, 3).Value = xmlDoc.SelectSingleNode("//log").getAttribute("number")
        Cells(3 + i, 4).Value = xmlDoc.SelectSingleNode("//sched").getAttribute("id")
        Cells(3 + i, 5).Value = xmlDoc.SelectSingleNode("//log").getAttribute("sn")

        Cells(3 + i, 6).Value = xmlDoc.SelectSingleNode("//seg/priamp").Text
        Cells(3 + i, 7).Value = xmlDoc.SelectSingleNode("//seg/bkgamp").Text
        Cells(3 + i, 8).Value = xmlDoc.SelectSingleNode("//seg/privolt").Text
        Cells(3 + i, 9).Value = xmlDoc.SelectSingleNode("//seg/bkgvolt").Text
        Cells(3 + i, 10).Value = xmlDoc.SelectSingleNode("//seg/pritrav").Text
        Cells(3 + i, 11).Value = xmlDoc.SelectSingleNode("//seg/bkgtrav").Text
        Cells(3 + i, 12).Value = xmlDoc.SelectSingleNode("//seg/priwire").Text
        Cells(3 + i, 13).Value = xmlDoc.SelectSingleNode("//seg/bkgwire").Text

        Cells(3 + i, 14).Value = xmlDoc.SelectSingleNode("//data/avg/priamp").Text
        Cells(3 + i, 15).Value = xmlDoc.SelectSingleNode("//data/avg/bkgamp").Text
        Cells(3 + i, 16).Value = xmlDoc.SelectSingleNode("//data/avg/privolt").Text
        Cells(3 + i, 17).Value = xmlDoc.SelectSingleNode("//data/avg/bkgvolt").Text
        Cells(3 + i, 18).Value = xmlDoc.SelectSingleNode("//data/avg/pritrav").Text
        Cells(3 + i, 19).Value = xmlDoc.SelectSingleNode("//data/avg/bkgtrav").Text
        Cells(3 + i, 20).Value = xmlDoc.SelectSingleNode("//data/avg/priwire").Text
        Cells(3 + i, 21).Value = xmlDoc.SelectSingleNode("//data/avg/bkgwire").Text

        Cells(3 + i, 22).Value = xmlDoc.SelectSingleNode("//log/time/day").Text & "/" & xmlDoc.SelectSingleNode("//log/time/mo").Text & "/" & xmlDoc.SelectSingleNode("//log/time/yr").Text
        Cells(3 + i, 23).Value = xmlDoc.SelectSingleNode("//log/time/hr").Text & ":" & xmlDoc.SelectSingleNode("//log/time/min").Text & ":" & xmlDoc.SelectSingleNode("//log/time/sec").Text
        Cells(3 + i, 24).Value = Cells(3 + i, 23).Value + (Cells(3 + i, 2).Value / 86400)
        Cells(3 + i, 25).Value = Cells(3 + i, 24).Value - Cells(3 + i, 23).Value


        ' Center all cells in the row b/c formatting is nice
        Range(Cells(3 + i, 1), Cells(3 + i, 26)).HorizontalAlignment = xlCenter

        ' Don't remember what this is for, but it probably resets the StrFile _
        variable to what it was before the loop
        StrFile = dir
        i = i + 1
    Loop

    ' Reset status bar
    Application.StatusBar = False
End Sub

Поскольку ежедневные журналы начинаются с последовательных имен, т. Е. LOG0001, LOG0002,LOG0003 и т. Д. Я не могу просто скопировать все файлы в одну папку, а затем запустить макрос.Я хотел бы изменить приведенный ниже код таким образом, чтобы при указании только основной папки «root» я мог загружать файлы из подпапок.

Буду признателен за любую помощь.

Answer 1

  Your code gets the fist file in the main folder with

    StrFile = dir(Address & "LOG*")


  and then loops through, filling the variable with the next filename using

   StrFile = dir() 

(Если вы используете dir без аргумента, он возвращает следующий файл в шаблоне, который вы использовали в последний раз.)

Вам нужно создать внешний цикл для поиска подкаталогов, а затем для каждого подкаталога изменить переменную адреса и перезапустить код. Так

    Dim subdir as string

    subdir = Dir(address,vbDirectory)
    do until len(subdir)=0
        StrFile = Dir(Address & "\" & subdir & "\LOG*")

        Do While Len(StrFile) > 0  
                'your existing code here

         StrFile = Dir()
        Loop
         SubDir = Dir()
     loop