AW: fortlaufende Nummerierung unterbinden
19.02.2010 17:39:12
fcs
Hallo Sandra,
das Makro so wie es ist erfordert, dass du Ghostscript und FreePDF installierst und in FreePDF ein Profil entsprechend meinen Amerkungen erstellst und als wählbaren Drucker einrichtest. Die genau Bezeichnung des Druckers unter VBA bekommst du durch Aufzeichnen eines Makros mit Auswahl des PDF-Druckers.
Mit "Speichern unter" als PDF unter Excel 2007 kann man die einzelnen Blätter nicht in der von dir gewünschten Form in eine einzige PDF-Datei ausgeben. Dazu müssen die selectierten Blätter jeweils in eine separate PDF-Datei geschrieben werden. Diese Dateien muss amn dann in Adobe Acrobat oder einem anderen PDF-Werkzeug in einem Document zusammenfassen.
Das Makro schaut dann etwa wie folgt aus. Das Verzeichnis in dem die erzeugten PDF-Dateien gespeichert werden sollen muss du natürlich anpassen.
Gruß
Franz
Sub Drucken_PDF_Excel2007()
Dim arrBlatt() As Object, iI As Integer, oActivesheet As Object
Dim sDatei As String, sPfad As String, oObjekt As Object
'Erzeugt unter Excel 2007 PDF-Dateien der selektierten Blätter
'Selektierte Blätter in einem Array merken
iI = 0
'Verzeichnis für die erzeugte(n) PDF-Datei(en)
sPfad = "C:\Users\Public\Documents\Adobe PDF\"
'Dateiname für PDF-Dateien = Name Exceldatei ohne ".xl...."
sDatei = ActiveWorkbook.Name
sDatei = Mid(sDatei, 1, InStrRev(sDatei, ".") - 1)
For Each oObjekt In ActiveWindow.SelectedSheets
iI = iI + 1
ReDim Preserve arrBlatt(1 To iI)
Set arrBlatt(iI) = oObjekt
Next
'Blätter einzeln als PDF ausgeben - Dateinamen werden fortlaufend nummeriert
Set oActivesheet = ActiveSheet
For iI = 1 To iI
arrBlatt(iI).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
sPfad & sDatei & Format(iI, "000") & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
oActivesheet.Activate
'Nach Ende des Druckvorgangs mussen die erzeugten PDF-Documente mit Adobe Acrobat _
oder einem anderen Werkzeug zu einer PDF-Datei zusammengefügt werden.
ReDim arrBlatt(0): Set oObjekt = Nothing
End Sub