Danke!
Sub AllesEinzeln()
Dim strPfad As String, strOpen As String
Dim lngI As Long
Dim wksSheets As Worksheet
' PFAD natürlich anpassen !!!
strPfad = "H:\EXCEL\Muell\Test"
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = strPfad
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For lngI = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(lngI)
strOpen = ActiveWorkbook.Name
For Each wksSheets In ActiveWorkbook.Worksheets
wksSheets.Copy
ActiveWorkbook.SaveAs strPfad & "\" & Left(strOpen, Len(strOpen) - 4) & wksSheets.Name & ".xls"
ActiveWorkbook.Close
Next wksSheets
Workbooks(strOpen).Close
Next lngI
End If
End With
Application.ScreenUpdating = True
End Sub