Option Explicit
Public Sub Save_As_PDF()
Dim i As Integer, PDFindex As Integer
Dim strFilePDF As String, strFileXL As String
Dim varResult As Variant
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
ThisWorkbook.Sheets("Sheet3").Range("A1:E86").Copy
wbNew.Sheets(1).Range("A1").PasteSpecial (xlPasteValuesAndNumberFormats)
wbNew.Sheets(1).Range("A1").PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
varResult = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Speichern", InitialFileName:="K:\" & "NPL" & Space(1) & Range("Daten!B4") & Space(1) & Range("Daten!B2") & Space(1) & Range("Daten!B3") & Space(1) & Format(Date, "YYYY-MM-DD"))
If varResult <> False Then
wbNew.SaveAs FileName:=varResult, FileFormat:=xlWorkbookNormal
Else
Exit Sub
End If
With Application.FileDialog(msoFileDialogSaveAs)
PDFindex = 0
For i = 1 To .Filters.Count
If InStr(VBA.UCase(.Filters(i).Description), "PDF") > 0 Then PDFindex = i
Next
.Title = "PDF"
.InitialFileName = "K:\" & "NPL" & Space(1) & Range("Daten!B4") & Space(1) & Range("Daten!B2") & Space(1) & Range("Daten!B3") & Space(1) & Format(Date, "YYYY-MM-DD")
.FilterIndex = PDFindex
If .Show Then
On Error GoTo Fehler
Sheets("Ausgabe").Range("A1:E86").ExportAsFixedFormat Type:=xlTypePDF, FileName:=.SelectedItems(1), _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, Openafterpublish:=True
Fehler:
With Err
Select Case .Number
Case 0
Case -2147018887
If MsgBox(strFilePDF & "Datei noch geöffnet, bitte schließen.", _
vbInformation + vbOKCancel, _
"Fehler") = vbOK Then
Resume
End If
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End If
End With
End Sub