Option Explicit
Sub Zusammenführen()
Dim oTargetBook As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oTargetBook = ActiveWorkbook
sPfad = ThisWorkbook.Path & "\MeinTest\"
sDatei = Dir(CStr(sPfad & "*.xl*"))
Do While sDatei <> ""
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True)
oSourceBook.Sheets(1).Copy after:=oTargetBook.Sheets(oTargetBook.Sheets.Count)
On Error Resume Next
oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = sDatei
If Err.Number <> 0 Then
Err.Numer = 0
Err.Clear
End If
On Error GoTo 0
oSourceBook.Close False
sDatei = Dir
Loop
End Sub