score:0

Accepted answer

This sub iterates through all files in a folder and if it finds any XMLs, it calls the second sub


Option Explicit

'in code editor: Tools > References > checkbox in Microsoft Scripting Runtime

Public Sub ProcessXMLs()
    Const FOLDER_NAME   As String = "C:\Tmp"        '<- update this path

    Dim tags As Variant, hdrs As Variant, rowID As Long
    Dim fso As FileSystemObject, f As File

    Set fso = New Scripting.FileSystemObject

    hdrs = Array("FileName", "ItemID", "Name", "GivenName", "FamilyName")
    tags = Array("FileName", "value", "name", "givenNames", "familyName")

    With Sheet1
        .Range(.Cells(1, 1), .Cells(1, UBound(tags) + 1)).Value2 = hdrs
        rowID = 2
        Application.ScreenUpdating = False
        For Each f In fso.GetFolder(FOLDER_NAME).Files   'iterate through files
            If LCase(fso.GetExtensionName(f)) = "xml" Then
                .Cells(rowID, 1).Value2 = fso.GetBaseName(f) & ".xml"
                ReadTags Sheet1, fso.OpenTextFile(f.Path, ForReading), rowID, tags
                rowID = rowID + 1
            End If
        Next
        .UsedRange.Columns.AutoFit
        Application.ScreenUpdating = True
    End With
End Sub

This sub extracts values in the 4 tags, one file at the time:

Private Sub ReadTags(ByVal ws As Worksheet, ByVal fsoFile As TextStream, _
                     ByVal rowID As Long, ByVal tags As Variant)

    Dim ln As String, val As String, i As Long, s1 As Long, s2 As Long

    With fsoFile
        Do While Not .AtEndOfStream       'file stream is open

            ln = Trim(.ReadLine)          'read each line

            If Len(ln) > 0 Then           'if text line is not empty extract tags
                For i = 1 To UBound(tags) 'find each tag - start and closing
                    s1 = InStr(1, ln, "<" & tags(i), 0)
                    s2 = InStr(s1 + 1, ln, "</" & tags(i) & ">", 0)
                    If s1 > 0 And s2 > 0 Then
                        s1 = InStr(s1, ln, """>", 0) + 2
                        ws.Cells(rowID, i + 1).Value2 = Trim(Mid(ln, s1, s2 - s1))
                        Exit For
                    End If
                Next
            End If
        Loop
    End With
End Sub

Result:

enter image description here


Related Query

More Query from same tag