Sub BlätterVerschieben()
Dim WB As Workbook, WS As Worksheet
Dim Bez(9) As Variant
Dim i As Integer
On Error GoTo ErrorHandler
Bez(0) = "Deutsch"
Bez(1) = "Italien"
Bez(2) = "England"
Bez(3) = "Südfrankreich"
Bez(4) = "Spanien"
Bez(5) = "Portugal"
Bez(6) = "Sonderl. Portugal"
Bez(7) = "Griechenland"
Bez(8) = "Spanien in EUR"
Bez(9) = "Sonderl. Span."
Application.ScreenUpdating = False
For i = 0 To UBound(Bez)
Set WB = Workbooks.Add
ThisWorkbook.Sheets(Bez(i)).Move Before:=WB.Sheets(1)
Application.DisplayAlerts = False
For Each WS In WB.Worksheets
If WS.Name <> Bez(i) Then WS.Delete
Next WS
Application.DisplayAlerts = True
WB.SaveAs "C:\PFAD\" & Bez(i) & ".xls"
WB.Close
Next i
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "Fehler!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub