Option Explicit
Sub AlleLesen()
Const cstrOutPath As String = "C:\Neuer Ordner\"
Const cstrInpPath As String = cstrOutPath & "XMLs\"
On Error GoTo ErrHandler
Dim strName As String
Dim strNewName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strName = Dir$(cstrInpPath & "*.xml")
While strName <> ""
Application.StatusBar = "Bearbeite: " & strName
strNewName = Replace(strName, ".xml", "", Compare:=vbTextCompare, Count:=1)
With Workbooks.Add()
While .Worksheets.Count > 1
.Worksheets(.Worksheets.Count).Delete
Wend
Select Case .XmlImport(cstrInpPath & strName, ImportMap:=Nothing, _
Destination:=.Worksheets(1).Range("A1"), _
Overwrite:=True)
Case xlXmlImportSuccess, xlXmlImportElementsTruncated
Call .SaveAs(cstrOutPath & strNewName, .FileFormat)
End Select
Call .Close(SaveChanges:=False)
End With
strName = Dir$()
Wend
SafeExit:
Application.StatusBar = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
GoTo SafeExit
End Sub