Xml to Excel with VBA

[JokerExecution]

Hello,
I've got a little problem with my project.
I have to create a workbook with a table with a button to import a folder full of xml files(columns are all the same).
My problem is that every xml file got a single table, so i cant work with them in a pivot chart or something else.

This is the best code I can find to work with but i dont know how to change it for my project...

Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, xFile$, lr%
Set xfdial = Application.FileDialog(msoFileDialogFolderPicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select a folder"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
Application.ScreenUpdating = False
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row    ' last used row, column A
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xmlWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    xmlWb.Sheets(1).UsedRange.Copy xSWb.ActiveSheet.Cells(lr, 1)
    lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
    xmlWb.Close False
    xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
MsgBox "End of code."
Exit Sub
ErrHandler:
MsgBox "Error!", , "Kutools for Excel"
End Sub

 

[Worf]

Hello

This code assumes each imported table has two header rows, so it starts copying from the third row.

All imported sheets are combined into one table. Even if there were multiple tables you could generate a pivot table by using the data model.

Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFolderPicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select a folder"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.count).End(xlUp).Row    ' last used row, column A
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xmlWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    If first Then
        Set r = xmlWb.Sheets(1).UsedRange                       ' with header
    Else
        xmlWb.Sheets(1).Activate
        Set r = ActiveSheet.UsedRange
        Set r = Range(Cells(3, 1), Cells(r.Rows.count, r.Columns.count))
    End If
    r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
    lr = xSWb.ActiveSheet.Range("a" & Rows.count).End(xlUp).Row
    xmlWb.Close False
    first = False
    xFile = Dir()
Loop
Application.ScreenUpdating = True
xSWb.Save
MsgBox "End of code."
Exit Sub
ErrHandler:
MsgBox "Error!"
End Sub

 

[JokerExecution]

Thank u very very much.