如何在Excel中使用VBA导入XML文件名和数据？

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

使用范围方法更新文件名。 变量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

Answer 2

您可以使用函数来检索文件名并添加：

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