Office 2010: "Speicherort" einmal abfragen und für weitere Dokumente merken

[meiki]

Hallo Zusammen,

ich möchte für die mit "x" ausgewählten Namen eine Urkunde als pdf speichern.

Hierbei hätte ich es gerne so, dass bei Klick auf den Button "Serienbrief" einmalig die Abfrage nach dem Speicherort erscheint und diese für alle weiteren Urkunden übernommen wird. Momentan wird der Speicherort noch für jedes pdf einzeln abgefragt.

Hat jemand hierzu einen Idee, wie ich meinen Code ändern kann  - mit meinen wenigen Kenntnissen komme ich leider nicht weiter :/.

Danke im voraus.

Gruß
Meiky

P.s.: Ich habe beide Codes für mein Anliegen ganz uncharmant zusammengewürfelt. Für Leute vom Fach könnte der Code grauenhaft erscheinen. . Auf Anpassungen und Entfernen von Überflüssigem darf man mich gerne auch aufmerksam machen.

Public Sub Seriendruck()
For a = 1 To Sheets("Eingabe").Cells(4, 5).End(xlDown).Row
    If CStr(Sheets("Eingabe").Cells(a, 2)) = "x" Then
        If CStr(Sheets("Eingabe").Cells(a, 6)) = "m" Then
            Sheets("form").Cells(9, 3).Value = "Sehr geehrter Herr"
        Else: Sheets("form").Cells(9, 3).Value = "Sehr geehrte Frau"
        End If
    Sheets("form").Cells(9, 13).Value = CStr(Sheets("Eingabe").Cells(a, 4))
    Sheets("form").Cells(9, 5).Value = CStr(Sheets("Eingabe").Cells(a, 5))

Call ErzeugePDF
    End If
Next a

Sheets("form").Select
Range("B7:H7").Select
    Selection.ClearContents
Range("M7").Delete
Sheets("Eingabe").Activate

End Sub


Sub ErzeugePDF()
   
    Dim intBlatt As Integer, arrBlatt() As String
    Dim objSheet As Object
    Dim Anzeigen As Boolean
    Dim Pfad As String, Datei As String, varDatei
    Anzeigen = False
   
    Pfad = ThisWorkbook.Path & "\"
    Datei = Sheets("form").Range("E9") & "_" & Sheets("form").Range("M9")
   
    varDatei = Application.GetSaveAsFilename(InitialFileName:=Pfad & Datei, _
            FileFilter:="PDF (*.pdf),*.pdf", _
            Title:="Bitte Ordner\Dateiname der PDF-Datei auswählen/eingeben")
   
    If varDatei = False Then Exit Sub
   
    With ThisWorkbook
        Application.ScreenUpdating = False
        For Each objSheet In .Sheets
            Select Case objSheet.Name
                Case "Eingabe"
                Case Else
                    If objSheet.Visible = True Then

                        intBlatt = intBlatt + 1
                        ReDim Preserve arrBlatt(1 To intBlatt)
                        arrBlatt(intBlatt) = objSheet.Name
                    End If
            End Select
        Next

        Application.ScreenUpdating = True

        If intBlatt > 0 Then
            .Sheets(arrBlatt).Select
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=varDatei, _
                OpenAfterPublish:=Anzeigen, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False

            Application.ScreenUpdating = False

            .Sheets("Eingabe").Select

             Application.ScreenUpdating = True
        Else
            MsgBox "Keine sichtbaren Blaetter für Ausgabe ins PDF gefunden!"
        End If
    End With

   
    Exit Sub
   
Err_Makro3_PDF1:
    MsgBox Prompt:="Der Pfad '" & Pfad & "' zum Speichern der PDF-Datei existiert nicht!" & vbNewLine & vbNewLine & _
                   "Daher keine Speicherung der PDF-Datei --> Abbruch!", _
           Buttons:=vbCritical + vbOKOnly, _
           Title:="Falscher Dateipfad"
End Sub