Office: VBA - Serienbriefe in einzelnen Dokumenten speichern

Hallo,

Ich möchte Serienbriefe mit Daten aus einem Excelsheet erstellen.
Dann sollen die Briefe als einzelne Word-Dokumente in einem Ordner abgespeichert werden.
Dazu soll ein Ordner, benannt mit dem tagesaktuellen Datum erstellt werden, in dem die Dokumente abgespeichert werden sollen.
Das Ordner-Erstellen funktioniert schon ganz gut.
Was nicht wirklich funktioniert ist das Abspeichern der Dokumente.
Sie sollen gespeichert werden, wenn in der Excel-Tabelle das Feld "Vorname" und "Nachname" ausgefüllt ist.
Momentan zeigt Word eine Fehlermeldung "Ein Problem wurde von Word festgestellt" an und erstellt auch, wenn das Feld "Vorname" oder "Nachname" nicht gefüllt ist, ein Dokument, das nicht im Ordner gespeichert wird und nur Serienbrief(Nummer) heißt.
Ich möchte eigentlich nur, dass die Dokumente zuverlässig im Ordner abgespeichert werden und dass es keine Fehlermeldung gibt.
Kann mir jemand weiterhelfen und mir evtl. sagen, wo der Fehler liegt?
Ich poste unten, was ich bisher habe.
Ich lerne das gerade noch, habe schon viele Tutorials angeschaut, komme hier nicht weiter und bin um jeden Rat sehr dankbar!

Viele Grüße und herzlichen Dank :-)
~~~~~~~~~

Sub briefe_erstellen()

'String für Ordnerpfad definieren
Dim strFolderPath As String
Dim Datum As String
strDatum = Format(Date, "JJJJ-MM-TT")
strFolderPath = "C:\Users\equi\Documents\Divers\XX\Rechnungen\Rechnung_backup_" & Format(Date, "YYYY-MM-DD")
' Überprüfen, ob Ordner bereits existiert
If Dir(strFolderPath, vbDirectory) = "" Then
' Ordner anlegen
MkDir (strFolderPath)
MsgBox "Ordner wurde angelegt!"
Else
MsgBox "Ordner ist vorhanden!"
End If

Dim nNachname As String
Dim nVorname As String

Dim Pfad As String


nNachname = "Nachname"
nVorname = "Vorname"

Pfad = "C:\Users\equi\Documents\Divers\XX\Rechnungen\Rechnung_backup_" & Format(Date, "YYYY-MM-DD")

' Anwendung ausblenden für bessere Leistung
MsgBox "Serienbriefe werden exportiert. Dieser Vorgang kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
Application.Visible = False


With ActiveDocument.MailMerge
.DataSource.ActiveRecord = wdLastRecord
anzahl = .DataSource.ActiveRecord
flag = False
For Each x In .DataSource.DataFields
If x.Name = nEmail Then
flag = True
Exit For
End If
Next
.Destination = wdSendToNewDocument
For i = 1 To anzahl
.DataSource.ActiveRecord = i
dsname = Pfad & "\" & _
.DataSource.DataFields(nVorname).Value & "_" & .DataSource.DataFields(nNachname).Value & "_" & Format(Date, "YYYY-MM-DD") & "_Rechnung.docx"
.DataSource.FirstRecord = i
.DataSource.LastRecord = i
.Execute
ActiveDocument.Range.Find.Execute findtext:="^b", replacewith:=""
Set fs = CreateObject("Scripting.FileSystemObject")

ActiveDocument.SaveAs FileName:=dsname, AddToRecentFiles:=False


Next i

End With
End Sub

 

Hallo LiMa,

du hast ein paar Ungereimtheiten in deinem Code:

• Einige Variablen hast du deklariert, andere wieder nicht. Ich empfehle dir, alle Variablen zu deklarieren, damit es nicht zu unvorhergesehenen Resultaten kommt.
• Unter den undeklarierten Variablen findet sich die Variable nEMail. Da ich nicht weiß, was sie enthalten soll, verstehe ich die Zeilen nicht:

For Each x In .DataSource.DataFields
'If x.Name = nEmail Then ...
Sollte das die Prüfung auf Vor- und Nachname sein? Ich hab sie gestrichen und durch eine Variante ersetzt.​

• Als Pfad hast du zwei Variablen im Code: strFolderPath und Pfad. Sie verweisen auf den gleichen Ordner. Vermutlich ein Versehen?
• Ziemlich am Ende definierst du ein undeklariertes ScriptingFileSystem-Objekt, verwendest es aber nicht. Was ist der Sinn davon?
• Wenn du Application.Visible = False setzt, solltest du es am Ende des Makros auf jeden Fall wieder auf True setzen, sonst siehst du ja nix. Besser noch eine Fehlerbehandlung machen, in im Falle eines Absturzes Visible trotzdem wieder auf True gesetzt wird.

Ich hab das Makro gemäß der obigen Anmerkungen angepasst:

Code:

Sub einzeln()

'Variablen deklarieren
Dim strFolderPath As String
Dim strDatum As String
Dim nNachname As String, nVorname As String, dsName As String
Dim i As Long, anzahl As Long

strDatum = Format(Date, "JJJJ-MM-TT")
strFolderPath = "C:\Users\equi\Documents\Divers\XX\Rechnungen\Rechnung_backup_" & Format(strDatum, "YYYY-MM-DD")
nNachname = "Nachname"
nVorname = "Vorname"

' Überprüfen, ob Ordner bereits existiert
    If Dir(strFolderPath, vbDirectory) = "" Then
        ' Ordner anlegen
        MkDir (strFolderPath)
        MsgBox "Ordner wurde angelegt!"
    Else
        MsgBox "Ordner ist vorhanden!"
    End If

'warum nochmal - kann weg?
'Dim Pfad As String
'Pfad = "C:\Users\equi\Documents\Divers\XX\Rechnungen\Rechnung_backup_" & Format(Date, "YYYY-MM-DD")

' Anwendung ausblenden für bessere Leistung
MsgBox "Serienbriefe werden exportiert. Dieser Vorgang kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
Application.Visible = False


With ActiveDocument.MailMerge
    .DataSource.ActiveRecord = wdLastRecord
    anzahl = .DataSource.ActiveRecord
    .Destination = wdSendToNewDocument
        For i = 1 To anzahl
        .DataSource.ActiveRecord = i
       
        'Prüfen, ob der Datensatz Nachname und Vorname enthält
            If .DataSource.DataFields(nNachname) <> "" And .DataSource.DataFields(nVorname) <> "" Then
                 dsName = strFolderPath & "\" & _
                 .DataSource.DataFields(nVorname).Value & "_" & .DataSource.DataFields(nNachname).Value & "_" & Format(strDatum, "YYYY-MM-DD") & "_Rechnung.docx"
                 
                 MsgBox dsName
                 .DataSource.FirstRecord = i
                 .DataSource.LastRecord = i
                 .Execute
                 ActiveDocument.Range.Find.Execute findtext:="^b", replacewith:=""
                 ActiveDocument.SaveAs FileName:=dsName, AddToRecentFiles:=False
                 
                 'vermutlich erwünscht: Dokument nach Speichern schließen:
                 ActiveDocument.Close
            End If
    Next i

End With

Application.Visible = True
End Sub

 

Hallo Gerhard, vielen, vielen Dank für diese ausführliche und konstruktive Antwort, das hilft mir sehr! Ich werde das morgen gleich mal ausprobieren! Grüße