Sub Export_and_Print_1()
Application.PrintCommunication = True
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim strTmpsheet As String
Dim strSource As String
Dim strSourceRange As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strSource = "Tabelle1"
strSourceRange = "A:A,D:D,F:F,G:G,H:H,J:J"
strTmpsheet = "temp-to-print.ttp"
strTime = Format(Now(), "yyyymmdd\_hhmmss")
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Bitte wählen Sie den Speicherort.")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ThisWorkbook.Sheets.Add.Name = strTmpsheet
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
End With
Sheets(strSource).Select
If myFile <> "False" Then
Range(strSourceRange).Select
Selection.Copy
Sheets(strTmpsheet).Select
ActiveSheet.Paste
Sheets(strTmpsheet).ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
MsgBox "PDF wurde erfolgreich erstellt: " _
& vbCrLf _
& myFile
ThisWorkbook.Sheets(strTmpsheet).Delete
End If
exitHandler:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
errHandler:
MsgBox "PDF konnte nicht erstellt werden!"
Resume exitHandler
End Sub