Re: fortlaufende Nummerierung unterbinden

Public Sub PrintSheetsToPDF( _
ByVal SheetsToPrint As Variant, _
ByVal PDFFilePath As String _
)
' Print the specified sheets to a PDF file in the order specified. Requires
' Adobe Acrobat 7.0 and a reference to Acrobat Distiller.
' Syntax
' PrintSheetsToPDF(Sheets, PDFFilePath)
' SheetsToPrint - Array of sheet names to be printed. The sheets included are
'   sorted in that order and then printed in one print job. When the printing
'   is complete the original order is restored.
' PDFFilePath - Full path to the PDF file.
' Example
' Print sheets "Sheet4", "Sheet10", and "Sheet1" in that order:
'   PrintSheetsToPDF Array("Sheet4", "Sheet10", "Sheet1", "C:\Output.PDF")
Dim OriginalActiveWorksheet As Worksheet
Dim OriginalOrderNames As Variant
Dim Index As Long
Dim PDFDistillerApplication As PdfDistiller
Dim TempPFFilePathName As String
Dim PDFLogPathName As String
Dim Result As Long
' Normalize the sheet to print parameter
If Not IsArray(SheetsToPrint) Then SheetsToPrint = Array(SheetsToPrint)
For Index = LBound(SheetsToPrint) To UBound(SheetsToPrint)
If TypeName(SheetsToPrint(Index)) = "Worksheet" Then SheetsToPrint(Index) = SheetsToPrint( _
Index).Name
Next Index
' Normalize the output pdf file name
If LCase(Right(PDFFilePath, 4))  ".pdf" Then PDFFilePath = PDFFilePath & ".pdf"
' Save the current active worksheet
Set OriginalActiveWorksheet = ActiveSheet
' Save the current sheet order
ReDim OriginalOrderNames(1 To ThisWorkbook.Sheets.Count)
For Index = 1 To ThisWorkbook.Sheets.Count
OriginalOrderNames(Index) = ThisWorkbook.Sheets(Index).Name
Next Index
' Reorder the worksheets
For Index = UBound(SheetsToPrint) To LBound(SheetsToPrint) Step -1
If ThisWorkbook.Sheets(SheetsToPrint(Index)).Index > 1 Then
ThisWorkbook.Sheets(SheetsToPrint(Index)).Move Before:=ThisWorkbook.Sheets(1)
End If
Next Index
' Print the worksheets
TempPFFilePathName = Left(PDFFilePath, InStrRev(PDFFilePath, ".")) & "pf"
PDFLogPathName = Left(PDFFilePath, InStrRev(PDFFilePath, ".")) & "log"
On Error Resume Next
Kill TempPFFilePathName
On Error GoTo 0
ThisWorkbook.Worksheets(SheetsToPrint).PrintOut ActivePrinter:="Adobe PDF", PrintToFile:= _
True, Collate:=True, PrToFilename:=TempPFFilePathName
' Restore the original worksheet order
For Index = 1 To ThisWorkbook.Sheets.Count
If ThisWorkbook.Sheets(OriginalOrderNames(Index)).Index  Index Then
ThisWorkbook.Sheets(OriginalOrderNames(Index)).Move Before:=ThisWorkbook.Sheets(Index)
End If
Next Index
' Restore the original active worksheet
OriginalActiveWorksheet.Activate
' Convert the postscript file to .pdf
Set PDFDistillerApplication = New PdfDistiller
Result = PDFDistillerApplication.FileToPDF(TempPFFilePathName, PDFFilePath, "")
On Error Resume Next
Kill TempPFFilePathName
If Result = 1 Then Kill PDFLogPathName
End Sub