Hallo,

versuchs mal so, ob es dir so passt:

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"
            'Speicherort-Abfrage und erzeugung des Dateinamens aus Feldern der Excel-Datei.
            .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
            'Hier wird eine PDF aus einem bestimmten Bereich eines bestimmten Tabellenblatt erzeugt.
            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 'Alles OK
                    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

Gruss Torsten