VBA PDF Funktion mit "Speichern unter" ergänzen

[kugelschreiber]

Hallo zusammen,

ich habe eine Möglichkeit gefunden (unter anderem durch eure Hilfe) ein Tabellenblatt als PDF zu exportieren und mit definiertem Namen abzuspeichern. (Code siehe unten) Nun habe ich allerdings das Problem mit dem absoluten Pfad. Sprich wird die Excel unter einem anderen Nutzernamen benutzt, funktioniert das Ganze nicht mehr.

Nun halte ich es für am Besten wäre, wenn der Nutzer selbst das Speicherziel auswählen kann, sprich mit "Speichern unter". Dabei sollte die Benennung nach definierten Zellbezügen bestehen bleiben. Sprich beim "Speichern unter" wird der Vorschlag zur Benennung gemacht. (Bsp: " & Range("G6") & "_" & Range("G10") & "_" & Range("G8") & ".pdf)

So muss der Nutzer lediglich den Zielordner auswählen und speichern klicken.


Natürlich habe ich schon eine Weile im Internet gestöbert und verschiedene Lösungsvorschläge ausprobiert,konnte mein Problem aber leider noch nicht lösen bzw. bin unsicher wo ich diese Codeschnipsel einfügen sollte.


Hier der aktuelle Code mit absolutem Zellbezug:


Sub PDF_Desktop()
'
'Querformat einstellen
Sheets("Beispiel").PageSetup.Orientation = 2 'Querformat

'Format automatisch anpassen
Sheets("Beispiel").PageSetup.Zoom = False
Sheets("Beispiel").PageSetup.FitToPagesWide = 1
Sheets("Beispiel").PageSetup.FitToPagesTall = 1


'Tabelle als PDF speichern
Sheets("Beispiel").Range("B2:X48").ExportAsFixedFormat xlTypePDF, _
Filename:="C:\Users\mustermann\Desktop\beispielordner\" & Range("G6") & "_" & Range("G10") & "_" & Range("G8") & ".pdf", _
Openafterpublish:=True


End Sub


Vielen Dank im Voraus für eure Hilfe![img]
Dateiupload bitte im Forum! So geht es: Klick mich!
]

[kugelschreiber]

Folgender Code sollte das Problem lösen:

Danke an Nutzer "Case".

Code:

Option Explicit
Public Sub Main()
    Dim varPath As Variant
    On Error GoTo Fin
    varPath = Application.GetSaveAsFilename( _
        InitialFileName:=ThisWorkbook.Path & "\" & Range("G6").Value & "_" & _
        Range("G10").Value & "_" & Range("G8").Value, _
        FileFilter:="PDF(*.pdf), *.pdf", _
        Title:="Speichern als PDF")
    If Not varPath = False Then
        With ThisWorkbook.Worksheets("Beispiel")
            .PageSetup.Orientation = 2
            .PageSetup.Zoom = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.FitToPagesTall = 1
            .Range("B2:X48").ExportAsFixedFormat 0, varPath, OpenAfterPublish:=True
        End With
    Else
        MsgBox "Abbrechen geklickt..."
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

[losgehts]

Hallo,

falls du auch das überschreiben der Dateien abfragen möchtest. So würde ich das machen:

Code:

Sub PDF_Desktop()
Dim vPfadName As Variant
'
'Querformat einstellen
Sheets("Beispiel").PageSetup.Orientation = 2 'Querformat

'Format automatisch anpassen
Sheets("Beispiel").PageSetup.Zoom = False
Sheets("Beispiel").PageSetup.FitToPagesWide = 1
Sheets("Beispiel").PageSetup.FitToPagesTall = 1

'DateiPfad+Name Vorschlag: Desktop des angemeldeten Users
Do
    vPfadName = Environ("USERPROFILE") & "\Desktop\" & Range("G6") & "_" & Range("G10") & "_" & Range("G8")
    vPfadName = Application.GetSaveAsFilename(vPfadName, "*.pdf,*.pdf", , "Wählen Sie einen Speicherort")
    If vPfadName = False Then Exit Sub          ' "Abbrechen" geklickt
    If Len(Dir(vPfadName)) <> 0 Then            ' Datei existiert bereits
        If MsgBox("Soll die Datei" & vbLf & vPfadName & vbLf & "überschrieben werden?", vbYesNo) = vbYes Then Exit Do
    End If
Loop While Len(Dir(vPfadName)) <> 0
    

'Tabelle als PDF speichern
Sheets("Beispiel").Range("B2:X48").ExportAsFixedFormat xlTypePDF, _
Filename:=vPfadName, _
Openafterpublish:=True

End Sub

Grüße, Ulrich

[kugelschreiber]

Vielen Dank für den Tipp!