Sub From_XML_To_XLS()
Dim myWb As Workbook
Dim mySWb As Workbook
Dim myStrPath As String
Dim myFileDialog As FileDialog
Dim myCount As Long
Dim myFile As String
On Error GoTo ErrHandler
Set myFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
myFileDialog.AllowMultiSelect = False
myFileDialog.Title = "Wählen Sie den gewünschten Ordner aus"
If myFileDialog.Show = -1 Then
myStrPath = myFileDialog.SelectedItems(1)
End If
If myStrPath = "" Then Exit Sub
Application.ScreenUpdating = False
myCount = 1
Set mySWb = ThisWorkbook
myFile = Dir(myStrPath & "\*.xml")
Do While myFile <> ""
Set myWb = Workbooks.OpenXML(myStrPath & "\" & myFile)
myWb.Sheets(1).UsedRange.Copy mySWb.Sheets(1).Cells(myCount, 1)
myWb.Close False
myCount = mySWb.Sheets(1).UsedRange.Rows.Count + 2
myFile = Dir()
Loop
Application.ScreenUpdating = True
mySWb.Save
Exit Sub
ErrHandler:
MsgBox "Keine xml-Dateien vorhanden", , "Meldung"
End Sub