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

Question

Я работал над макрос-сценарием VBA, чтобы помочь импортировать и организовывать XML-файлы в соответствии с запросами пользователей. Однако сейчас я пытаюсь добавить имя файла, так как оно содержит имя пользователя, отправившего этот конкретный файл XML. Мне удалось сформулировать код для импорта XML и добавить имя файла в конце каждого импорта XML, но теперь я хочу импортировать имя файла вместе с данными (как в каждой строке в конце столбца). Как показано с XXX, обозначающим данные XML:

XXX1    XXX1  filename1  
XXX1    XXX1  filename1  
XXX1    XXX1  filename1  
XXX2    XXX2  filename2  
XXX2    XXX2  filename2  
XXX2    XXX2  filename2

Прямо сейчас мой код выглядит так

Option Explicit

Sub LoopThroughFiles()

    Dim strFile As String, strPath As String, Num As Long, LR As Integer

    strPath = "C:\Requests\"
    strFile = Dir(strPath & "*.xml")
    Num = 0

    While strFile <> ""

        ActiveWorkbook.XmlMaps("resources_Map").Import Url:= _
        (strPath & strFile)

        strFile = Dir

        Num = Num + 1

        LR = Cells(Rows.Count, "A").End(xlUp).Row
        LR = LR + 1
        Cells(LR, "A") = strFile

    Wend

MsgBox "This code ran successfully for " & Num & " XML file(s)", vbInformation

End Sub

Текущий код работает так:

XXX1 XXX1  
filename1  
XXX2  XXX2  
filename2  

Это выглядит как простое добавление столбца, но я не уверен, как добавить значения ко всем строкам в импорте XML. Заранее спасибо!

Answer 1

Вы можете использовать функцию для извлечения имен файлов и добавления:

Option Explicit
Public Sub AddFileNames()
    Dim destinationCell As Range, results() As String
    Set destinationCell = ActiveSheet.Range("A1")  '<==Set to first cell where you want to add the names from
    results = GetXMLFileNames("C:\Requests\*.xml")
    If results(UBound(results)) <> vbNullString Then
        destinationCell.Resize(UBound(results) + 1, 1) = Application.WorksheetFunction.Transpose(results)
    End If
End Sub

Public Function GetXMLFileNames(ByVal folderPath As String) As Variant
    Dim f As String, names() As String, counter As Long
    ReDim names(0 To 1000)
    f = Dir(folderPath)
    Do Until f = vbNullString
        names(counter) = f
        f = Dir
        counter = counter + 1
    Loop
    ReDim Preserve names(0 To counter - 1)
    GetXMLFileNames = names
End Function

Answer 2

Используйте Range метод для обновления имен файлов. переменные lngStart и lngEnd будут иметь номера начальной и конечной строк.

Option Explicit

Sub LoopThroughFiles()
    Dim strFile As String, strPath As String, Num As Long, LR As Integer
    Dim lngStart, lngEnd As Long

    strPath = "C:\Requests\"
    strFile = Dir(strPath & "*.xml")
    Num = 0

    lngStart = 2 'considering row 1 has headers. if not change it to 1.
    While strFile <> ""

        ActiveWorkbook.XmlMaps("resources_Map").Import URL:= _
        (strPath & strFile)

        strFile = Dir

        Num = Num + 1

        lngEnd = Cells(Rows.Count, "A").End(xlUp).Row
        Range("B" & lngStart & ":B" & lngEnd).Value = strFile

        lngStart = lngEnd + 1

    Wend

MsgBox "This code ran successfully for " & Num & " XML file(s)", vbInformation

End Sub