Arbeitsblätter in jeweils einer eigenen Arbeitsmappe speichern

Die folgende Prozedur speichert alle Arbeitsblätter einer Mappe in jeweils extra Arbeitsmappen ab. Die neu erzeugten Arbeitsmappen werden im gleichen Verzeichnis abgelegt, in dem sich die Ausgangsdatei befindet.

Sub Arbeitsblaeter_speichern()
'** Aufrufen der Speicherprozuedur
Call SheetsSpeichern(ActiveWorkbook)
End Sub

Public Sub SheetsSpeichern(Wkb As Workbook)
'** Prozedur zum extrahieren und speichern der einzelnen Arbeitsblätter

Dim bScreenUpdating As Boolean
Dim bEnableEvents As Boolean
Dim tPath As String
Dim tFileName As String
Dim tSheetName As String
Dim oSheet As Object

With Application
bScreenUpdating = .ScreenUpdating
bEnableEvents = .EnableEvents
.ScreenUpdating = False
.EnableEvents = False

tPath = Wkb.Path & Application.PathSeparator
tFileName = WorksheetFunction.Substitute(Wkb.Name, ".xls", vbNullString)

For Each oSheet In Wkb.Sheets
oSheet.Copy
With ActiveWorkbook
   tSheetName = oSheet.Name
   .SaveAs tPath & tFileName & "_" & tSheetName & ".xls"
   .Close SaveChanges:=False
End With
Next oSheet

.ScreenUpdating = bScreenUpdating
.EnableEvents = bEnableEvents
End With

End Sub