102006

Die folgende Prozedur speichert alle Arbeitsblätter einer Mappe in

jeweils extra Arbeitsmappen ab.

Die neu erzeugten Arbeitsmappen werden im Root-Verzeichnis abgelegt.

Dieses Makro ist aufzurufen.

Sub Test()

Call SheetsSpeichern(ActiveWorkbook)

End Sub

_______________________________________________________________

Public Sub SheetsSpeichern(Wkb As Workbook)

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