VBA PDF & Mail bestimmte Register

Liebe Excel-Profis,
ich hoffe Ihr könnt mir helfen.

Ich muss eine Liste von Anschreiben mit Anlagen erstellen (Datenbank ähnlich) und diese dann auch als PDF erzeugen, speichern und gleich auch versenden.

Die Excel besteht also aus 5 Registerblättern:
1. die Liste (Register "Liste")
2. das Anschreiben ("Brief")
3. Anlage 1 ("Vertrag")
4. Anlage 2 ("Belege") und
5. Hilfsseite für den Email-Versand ("Mail")

Das Anschreiben ("Brief") enthält Formeln, die immer die Daten der letzten befüllten Zelle von dem Register "Liste" nehmen. So ist das Anschreiben immer up-to-date zum letzten Eintrag in der Liste.

Dateiname und Pfad habe ich ebenfalls bereits in der Liste mit Formeln definiert und sollen dort entnommen werden. Die Excel-Datei liegt aber woanders, nicht im gleichen Pfad wie die zu erzeugenden PDF's.

Mit Excel-Formel mailto stoße ich mit 255 Zeichen an die Grenze und eine PDF mit Formel anhängen geht auch nicht. Also bleibt nur ein komplexes Makro, das Folgendes machen soll:

1. PDF's bestimmter Register generieren und speichern
Aus den 3 Sheets "Anschreiben", "Vertrag" und "Belege" jeweils eine separate PDF erzeugen und speichern ...

1a) und zwar in dem Pfad, der in der Liste in der letzten Spalte steht. Das Unterverzeichnis entspricht dem gekürzten Firmenname der Liste (Spalte D; gelb markiert). Wenn das Verzeichnis noch nicht existiert, dann soll es erzeugt werden. Dann finde ich nämlich jeden Adressat im Verzeichnis mit eigenem Ordner, und in diesem liegen dann die 3 PDF-Dateien.

1b) Der Dateiname soll ebenfalls aus den Zellen in der Arbeitsmappe entnommen werden: Datum_Firma_Registername.pdf
>> Datum: Datum-Format: YYYY-MM-TT Quelle: Register "Anschreiben" oben rechts
>> Firma: gekürzter Firmenname im Register "Liste", Spalte D
>> Registername: Name des Blattregisters

So sollte das dann idealerweise in meinem Explorer zu finden sein:
Z:\Dateien\Dateien-Privat\Behörden\Lectus\ 2023-05-20_Lectus_Anschreiben.pdf
2023-05-20_Lectus_Vertrag.pdf
2023-05-20_Lectus_Belege.pdf

2. Als Email versenden
Die drei PDFs sollen direkt nach dem Erzeugen auch gleich als Email-Anhang in eine neue Mail (Outlook 2021) eingefügt werden. Adressat, Betreff und Email-Text sind ebenfalls in Zellen - im Register "Email".

Das Trickige an der Sache: das Makro soll immer nur die letzte beschriebene Zeile in der Liste bearbeiten und alles im Hintergrund ausführen (also nicht sichtbar die Tabellenblätter wechseln und Ladebalken anzeigen, das irritiert nur).

Ich bin absoluter Laie in Sachen VBA, aber habe mich fleißig die letzten 2 Wochen durchgefräst und Makros aus dem Netz probiert - aber keines gefunden, was meine Kombination hat. Und Selberbasteln endete in einer Katastrophe von Fehlermeldungen.

Jetzt frage ich hier mal, ob mir Jemand so ein Script in meine Datei basteln kann? Ich habe sie hier, aber der Upload meckert, dass sie zu groß sei (mit 971kb). Die müsste ich dann also per Email oder WeTransfer senden.

Kann mir Jemand von Euch Profis bitte bitte helfen? Mir läuft langsam die Zeit weg ... 2 Wochen Selbstversuche sind schon drauf gegangen.

Danke schon mal im Voraus :-)
Felizia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ZuPDF() Dim DerPfad As String, DieFirma As String Dim letzteZeile As Long Dim wks As Worksheet Dim strPDF With Worksheets("Liste") letzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte Zeile in A DieFirma = .Cells(letzteZeile, 4) 'Firma in D DerPfad = .Cells(letzteZeile, 10) 'Pfad in J , anpassen End With If Right(DerPfad, 1) > "\" Then DerPfad = DerPfad & "\" DerPfad = DerPfad & DieFirma If Dir(DerPfad, vbDirectory) = "" Then MkDir DerPfad For Each wks In Sheets(Array("Anschreiben", "Vertrag", "Belege")) strPDF = DerPfad & "\" & Format(Date, "YYYY-MM-DD") & "_" & DieFirma & "_" & wks.Name & ".pdf" wks.ExportAsFixedFormat xlTypePDF, strPDF Next wks End Sub

Hi Feli
Teste bitte mal


Option Explicit
'Hab das Blatt Brief auch Anschreiben genannt, damit Klarheit herrscht
'bitte keine differierenden Namen verwenden
'In der Datei einen Namen Stammpfad in beliebiger Zelle vergeben !!
Public strStammpfad As String

Public strPDFAnschreiben As String
Public strPDFVertrag As String
Public strPDFBelege As String
Public strDatum As String
Public strFirma As String

Public strFROM As String
Public strTO As String
Public strBODY As String
Public strSUBJECT As String

Public Sub Main()
    Dim rg As Range, rgZelle As Range
    If Not exportierePDF Then
        MsgBox "Fehler beim Erstellen von PDFs"
        Exit Sub
    End If
    strFROM = ThisWorkbook.Worksheets("Email").Range("A10").Value
    Set rg = ThisWorkbook.Worksheets("Email").Range("A2:A10")
    For Each rgZelle In rg.Cells
        strBODY = strBODY & vbCrLf & rgZelle.Value
    Next
    strBODY = strBODY
    'Es ist nicht vorgegeben wie die Titelzeile der Mail entsteht !!
    strSUBJECT = "Wie hier zu sehen mit strFrom ein Subject für die Titelzeile angeben bspw in Email/A1 !!!"
    If mailSenden() Then
        MsgBox "Fehler beim Versenden"
        Exit Sub
    End If
End Sub

Public Function mailSenden() As Boolean
    On Error GoTo mailSendenERR
    Const olMailItem = 0
    Dim objOutlook As Object
    Dim objEmail As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Set objEmail = objOutlook.CreateItem(olMailItem)
    With objEmail
        .to = strTO
        .Subject = strSUBJECT
        .Body = strBODY
        .Attachments.Add (strPDFAnschreiben)
        .Attachments.Add (strPDFVertrag)
        .Attachments.Add (strPDFBelege)
        'Display deaktivieren und Send aktivieren
        .Display
        '.Send
    End With
    mailSenden = True
mailSendenOUT:
    Set objEmail = Nothing
    Set objOutlook = Nothing
    Exit Function
mailSendenERR:
    mailSenden = False
    Resume mailSendenOUT
End Function

'Export der Dateien, bei Erfolg sind die Dateipfade und eMail-To gesetzt
Public Function exportierePDF() As Boolean
    On Local Error GoTo exportierePDFERR
    Dim strDatei As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rg As Range
    Dim intZeile As Integer
    Dim bErgebnis As Boolean
    strStammpfad = ThisWorkbook.Names("Stammpfad").RefersToRange(1)
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Liste")
    intZeile = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    strFirma = Trim(ws.Cells(intZeile, 4).Value)
    strTO = ws.Cells(intZeile, 9).Value
    Set ws = wb.Worksheets("Anschreiben")
    strDatum = Format(ws.Cells(8, 5).Value, "yyyy-mm-dd")
    Dim strNeuerPfad As String
    strNeuerPfad = strStammpfad & "\" & strFirma
    If Dir(strNeuerPfad, vbDirectory) = "" Then
        MkDir strNeuerPfad
    End If
    strDatei = strNeuerPfad & "\" & strDatum & "_" & strFirma & "_Anschreiben.pdf"
    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDatei, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False, From:=1, to:=1
    strPDFAnschreiben = strDatei
    Set ws = wb.Worksheets("Vertrag")
    strDatei = strNeuerPfad & "\" & strDatum & "_" & strFirma & "_Vertrag.pdf"
    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDatei, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=True, OpenAfterPublish:=False, From:=1, to:=1
    strPDFVertrag = strDatei
    Set ws = wb.Worksheets("Belege")
    strDatei = strNeuerPfad & "\" & strDatum & "_" & strFirma & "_Belege.pdf"
    ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDatei, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=True, OpenAfterPublish:=False, From:=1, to:=1
    strPDFBelege = strDatei
    bErgebnis = True
exportierePDFOUT:
    exportierePDF = bErgebnis
    Exit Function
exportierePDFERR:
    bErgebnis = False
    Resume exportierePDFOUT
End Function

hth
Ulf

Beliebteste Forumthreads (12 Monate)

VBA PDF & Mail bestimmte Register

30 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

30
Beiträge zum Forumthread

Beiträge zu diesem Forumthread