XML zu Excel mit Vba

Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range, p As PivotTable
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
Application.ScreenUpdating = False
Set xSWb = ThisWorkbook
xSWb.Sheets(3).Cells.Clear
xSWb.Sheets(2).Activate
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
xSWb.Sheets(1).Activate
For Each p In ActiveSheet.PivotTables
p.RefreshTable
Next p
Application.ScreenUpdating = True
xSWb.Save
MsgBox "End of code."
Exit Sub
ErrHandler:
MsgBox "Error!"
End Sub