Option Explicit
Sub zustel()
Dim strDatnam As String
Dim wb As Workbook
Dim ws As Worksheet
strDatnam = Dir("c:\eigene Dateien\xy\*.xls")
Do While Len(strDatnam)
Set wb = Workbooks.Open(strDatnam)
Set ws = ThisWorkbook.Sheets.Add
ws.Name = Split(strDatnam, Application.PathSeparator)(UBound(Split(strDatnam, Application. _
PathSeparator)))
wb.Sheets(1).Cells.Copy Destination:=ws.Cells
wb.Close savechanges:=False
strDatnam = Dir
Loop
Set ws = Nothing
Set wb = Nothing
End Sub
Vielen Dank