如何在 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

使用 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

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