AW: Variable Arbeitsblätter als pdf exportieren
10.06.2015 10:33:50
fcs
Hallo Sarah,
nachfolgend ein entsprechendes Makro, dass du ggf. noch ein wenig anpassen muss.
Gruß
Franz
Sub PDF_Speichern()
Dim arrSheets() As String, Zeile As Long, intS As Integer, objSheet As Object
Dim objSheetAktiv As Object
Dim strSheet As String, strDateiPDF
Dim wksAuswahl As Worksheet
Dim StatusMapPaperSize As Boolean
'Die nachfolgenden Konstanten ggf. anpassen
Const SpaName As Long = 1 'Spalte A - Spalte mit den Blattnamen
Const SpaX As Long = 2 'Spalte B - Spalte mit den "x"
Const ZeiName_1 As Long = 2 'Zeile mit dem 1. Blattnamen
Const varAuswahl As Variant = 1 'Blatt mit derAuswahlliste, Index-Nr. _
ggf. anpassen oder Blattname in Anführungszeichen verwenden
On Error GoTo Fehler
With ActiveWorkbook
'Datei-Auswahl-Dialog für Name der PDF-Datei anzeigen
strDateiPDF = Application.GetSaveAsFilename(InitialFileName:= _
Left(.Name, InStrRev(.Name, ".") - 1) & Format(Now, " YYYY-MM-DD hhmmss"), _
FileFilter:="PDF-Datei (*.pdf),*.pdf", _
Title:="Bitte Dateiname für PDF-Datei eingeben/auswählen")
End With
If strDateiPDF = False Then Exit Sub
'Blatt mit mit Auswahlliste setzen
Set wksAuswahl = ActiveWorkbook.Worksheets(varAuswahl)
'Option - Inhalt für Papierformate A4 oder 8.5 x 11 Zoll skalieren
StatusMapPaperSize = Application.MapPaperSize 'Status merken
Application.MapPaperSize = False 'Option deaktivieren
Set objSheetAktiv = ActiveSheet 'aktives Blatt merken
'markierte Blattnamen in Datenarray sammeln
With wksAuswahl
For Zeile = ZeiName_1 To .Cells(.Rows.Count, SpaName).End(xlUp).Row
strSheet = .Cells(Zeile, SpaName).Text 'Blattname in Spalte A
'Prüfen, ob in Spalte B der Zeile ein "x" oder "X" eingetragen ist
If UCase(.Cells(Zeile, SpaX).Text) = "X" Then
Set objSheet = ActiveWorkbook.Worksheets(strSheet)
intS = intS + 1
ReDim Preserve arrSheets(1 To intS)
'Blattname aus Spalte A in
arrSheets(intS) = strSheet
End If
Next_Zeile:
Next Zeile
End With
If intS > 0 Then
'markierte Blätter selektieren und als PDF-Speichern.
ActiveWorkbook.Sheets(arrSheets).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strDateiPDF, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "Es wurden keine Blätter zur Ausgabe ins PDF gewählt!", _
vbOKOnly, "PDF erzeugen"
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles Ok
Case 9 'Index-Fehler - Blatt mit Name existiert nicht
If MsgBox("Index-Fehler - Blatt mit Name """ & strSheet & """ existiert nicht", _
vbRetryCancel, "PDF erzeugen") = vbRetry Then
Resume Next_Zeile
End If
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
objSheetAktiv.Select
Application.MapPaperSize = StatusMapPaperSize 'Option zurücksetzen
End Sub