AW: Neue Mappe für jedes Tabellenblatt
04.09.2012 12:31:15
fcs
Hallo Tobi,
der Basisansatz ist der gleiche wie bei Rudi.
Ich hab noch eine Prüfung auf gerade Blattzahl eingebaut und es wird auf Wunsch nach jedem Pärchen der Speichern-Unter-Dialog angezeigt.
Gruß
Franz
Sub CopySheetPaerchen()
'Jeweils 2 Tabellenblätter in neue Arbeitsmappe kopieren
Dim wbk_Aktiv As Workbook, wbk_Z As Workbook, bolLast As Boolean
Dim arrSheet(1 To 2) As Integer
Dim intI As Integer
Dim bolSaveas As Boolean
If MsgBox("Soll der Speichern-Unter-Dialog nach jedem Pärchen angezeigt werden?", _
vbQuestion + vbYesNo, _
"Tabellenblätter pärchenweise kopieren in Mappen") = vbYes Then bolSaveas = True
Set wbk_Aktiv = ActiveWorkbook
With wbk_Aktiv
bolLast = True
If .Sheets.Count Mod 2 = 1 Then
If MsgBox( _
"Anzahl Blätter in Arbeitsmappe ist ungerade, letztes Blatt als Einzelblatt kopieren?", _
vbYesNo + vbQuestion + vbDefaultButton2, _
"Tabellenblätter pärchenweise kopieren in Mappen") = vbNo Then
bolLast = False
End If
End If
For intI = 1 To .Sheets.Count Step 2
arrSheet(1) = intI
arrSheet(2) = intI + 1
If arrSheet(2) > .Sheets.Count Then
If bolLast = True Then
.Sheets(intI).Copy
End If
Else
.Sheets(arrSheet).Copy
End If
Set wbk_Z = ActiveWorkbook
If bolSaveas = True Then
Application.Dialogs(xlDialogSaveAs).Show IIf(InStr(1, .Name, ".xls") > 0, _
Left(.Name, InStrRev(.Name, ".xls") - 1), .Name) _
& " " & intI & IIf(intI + 1