"Speicherort" merken

[meiky]

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

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

[Kuwer]

Hallo Meiky,

Code:

Public Sub Seriendruck()
 Dim a As Long
 Dim Pfad As String, Datei As String, strDatei As String
 
 Pfad = ThisWorkbook.Path & "\"
 Datei = Sheets("form").Range("E9") & "_" & Sheets("form").Range("M9")
 strDatei = Application.GetSaveAsFilename(InitialFileName:=Pfad & Datei, _
             FileFilter:="PDF (*.pdf),*.pdf", _
             Title:="Bitte Ordner\Dateiname der PDF-Datei auswählen/eingeben")
 If Not CVar(strDatei) = False Then
   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(strDatei)
     End If
   Next a
   
   Sheets("form").Range("B7:H7").ClearContents
   Sheets("form").Range("M7").Delete
 End If
End Sub

Sub ErzeugePDF(strDatei As String)
   
   Dim intBlatt As Integer, arrBlatt() As String
   Dim objSheet As Object
   Dim Anzeigen As Boolean
   Dim Pfad As String, Datei As String, strDatei
   Anzeigen = False
 
   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:=strDatei, _
               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

Gruß Uwe

[meiky]

Hi Uwe,

danke für deine Hilfe. Ich habe deinen Code eingefügt. Leider kommt beim ausführen "Fehler beim Kompilieren: Mehrfachdeklaration im aktuellen Gültigkeitsbereich." (siehe Screenshot)

Wenn ich das strDatei rauslösche wird leider nur EIN leeres PDF (Ohne Namen) gespeichert.

Was mache ich noch falsch? Ich habe meinen alten Code gelöscht und deinen vorsichtshalber in Seriendruck2 und Erzeuge_PDF2 umbenannt.

Kannst du mir nochmal weiterhelfen?

Grüße

[Kuwer]

Hallo Meiky,

lösche die komplette Zeile (hatte ich vergessen   ).

Gruß Uwe

[meiky]

Dank dir! Funktioniert =) :19:  yippie