Office: (Office 2016) VBA Serienbrief in einzelne Ordner speichern

Moin,

ich habe ein Serienbriefdokument. Derzeit ist es möglich, mit VBA alle Dokumente nach Nachnamen und Vornamen aus der Excelquelle einzeln zu speichern. Ich würde nun gerne auch das die Dokumente in einzeln nach Quelle definierten Ordnern (nach Termin) gespeichert werden. Die Ordner sollen dabei automatisch erstellt werden.

Kurzes und hoffentlich verständliches Beispiel
Dokumente namens Serienbrief.docx liegt unter C:\Neuer Ordner\Seriendruck\

Die Datenquelle ist wie folgt:
Name: Mustermann; Vorname: Klaus; Termin: 22.02.2023
Name: Musterfrau; Vorname: Beate; Termin: 23.02.2023

Zurzeit speichert er mit dem Makro die 2 Dateien unter
1. C:\Neuer Ordner\Mustermann Klaus.docx
2. C:\Neuer Ordner\Musterfrau Beate.docx

Gerne hätte ich aber:
1. C:\Neuer Ordner\Termin 22.02.2023\Mustermann Klaus.docx
2. C:\Neuer Ordner\Termin 23.02.2023\Musterfrau Beate.docx

derzeitiger VBA Code:

Code:

Sub JederDatensatzInEineEigeneDatei()

Dim i As Long
Dim anzahl As Long
Dim dateiname As String
Dim Pfad As String

Pfad = ThisDocument.Path

With ActiveDocument.MailMerge
If .MainDocumentType = wdNotAMergeDocument Then
MsgBox "Das Dokument ist noch nicht mit einer Seriendruckquelle verbunden."
Exit Sub
End If

'Anzahl Datensätze feststellen, Abbruch bei 0
.DataSource.ActiveRecord = wdLastDataSourceRecord
anzahl = .DataSource.ActiveRecord
.DataSource.ActiveRecord = 1

If anzahl = 0 Then
MsgBox "Es wurden keine Datensätze gefunden."
Exit Sub
End If

.Destination = wdSendToNewDocument

For i = 1 To anzahl
.DataSource.ActiveRecord = i

dateiname = Pfad & " " & .DataSource.DataFields("Name").Value & " " & .DataSource.DataFields("Vorname").Value

'macht dem Seriendruck vor, dass es bei jedem Durchgang nur 1 Datensatz gibt
.DataSource.FirstRecord = i
.DataSource.LastRecord = i
.Execute

With ActiveDocument
'Schönheitssache: löscht den abschließenden Abschnittsumbruch
.Range.Find.Execute findtext:="^b", replacewith:=""

'Speichern als .docx
.SaveAs FileName:=dateiname & ".docx", AddToRecentFiles:=False
.Close
End With

Next i

.DataSource.FirstRecord = 1
End With
MsgBox anzahl & " Dateien erstellt."
End Sub

Ich hoffe ihr könnt mir helfen?

Liebe Grüße
Jessy

 

Hallo Jessy,

teste diesen angepassten Code. Den Startordner musst du natürlich an deine Gegebenheiten anpassen.

Code:

Sub JederDatensatzInEinenEigenenOrdner()
Dim i As Long, anzahl As Long
Dim pfad As String, dateiname As String
Dim fso As Object, zielOrdner As Object

Set fso = CreateObject("Scripting.FileSystemObject")
pfad = "C:\1temp\" '*** das ist der Startordner -  anpassen

If Not fso.FolderExists(pfad) Then
    MsgBox "Bitte Startordner anlegen"
    Exit Sub
End If

With ActiveDocument.MailMerge
        If .MainDocumentType = wdNotAMergeDocument Then
           MsgBox "Das Dokument ist noch nicht mit einer Seriendruckquelle verbunden."
           Exit Sub
        End If
   
    'Anzahl Datensätze feststellen, Abbruch bei 0
    anzahl = .DataSource.RecordCount
   
        If anzahl = 0 Then
            MsgBox "Es wurden keine Datensätze gefunden."
            Exit Sub
        End If
       
    .Destination = wdSendToNewDocument
   
        For i = 1 To anzahl
            With .DataSource
             .ActiveRecord = i
             
               If fso.FolderExists(pfad & Format(.DataFields("Termin"), "dd.mm.yyyy")) Then
                   Set zielOrdner = fso.GetFolder(pfad & Format(.DataFields("Termin"), "dd.mm.yyyy"))
               Else
                   Set zielOrdner = fso.CreateFolder(pfad & Format(.DataFields("Termin"), "dd.mm.yyyy"))
              End If
           
             dateiname = zielOrdner & "\" & .DataFields("Nachname").Value & "_" & .DataFields("Vorname").Value
           
             'macht dem Seriendruck vor, dass es bei jedem Durchgang nur 1 Datensatz gibt
             .FirstRecord = i
             .LastRecord = i
          End With
          .Execute
         
          With ActiveDocument
              'Schönheitssache: löscht den abschließenden Abschnittsumbruch
              .Range.Find.Execute findtext:="^b", replacewith:=""
             
              'Speichern als .docx
              .SaveAs FileName:=dateiname & ".docx", AddToRecentFiles:=False
              .Close
          End With
        Next i
       
    .DataSource.FirstRecord = 1
End With
MsgBox anzahl & " Dateien erstellt."
End Sub

 

Hallo Gerhard,

Danke schonmal für deine nächtliche Antwort.

mit deinem Code legt er quasi einen Ordner names 1temp22.03.2022 unter C:\ an. Einen weiteren Ordner für den 2 Datensatz oder Dateien legt er nicht an.

Abbruch mit Fehler:
Laufzeitfehler '5941':
Das angeforderte Element ist nicht in der Sammlung vorhanden.

 

Hallo Jessy,

den Ordner 1temp legt das Makro gar nicht an, den muss es schon geben. Wenn nicht, erscheint die Meldung: "Bitte Startordner anlegen" und das Makro wird abgebrochen. Wenn du einen eigenen Startordner erstellst, vergiss nicht, dass er im Code mit einem Backslash am Ende notiert werden muss.

Ansonsten brauch ich die Zeile, in der die Fehlermeldung entsteht. Gehe dafür den Code im Einzelschritt (mit F8) durch und teile die Zeile mit, in der die Fehlermeldung erscheint.

 

War mein Fehler sorry. Der Ordner war natürlich angelegt. Hatte ich doof formuliert. Das Backslash hatte natürlich gefehlt Der Fehler kam aufgrund eines Schreibfehlers in der Datenquelle.

Läuft jetzt super danke danke danke!

PS: Würde es auch gehen 2 Ordner anzulegen? Also einen Odner mit dem Termin und dann darin einen Ordner "Vorname Nachname" und darin dann die Datei? Ich habe es eben selbst schon versucht, aber dazu reichen meine Anfängerkenntnisse nicht aus. Zufrieden bin ich allemal. Es wäre nur das i-Tüpfelchen

 

Hallo Jessy,

das würde bedeuten, dass in den jeweiligen "Vorname Nachname"-Ordnern auch immer nur 1 Datei liegt? Das geht schon. Teste mal dies:

Code:

Sub JederDatensatzInEinenEigenenOrdner()
Dim i As Long, anzahl As Long
Dim strStartordner As String, strNamensordner As String, strDateiname As String
Dim fso As Object, Datumsordner As Object, namensOrdner As Object

Set fso = CreateObject("Scripting.FileSystemObject")
strStartordner = "C:\1temp\" '*** das ist der Startordner -  anpassen

If Not fso.FolderExists(strStartordner) Then
    MsgBox "Bitte Startordner anlegen"
    Exit Sub
End If

With ActiveDocument.MailMerge
        If .MainDocumentType = wdNotAMergeDocument Then
           MsgBox "Das Dokument ist noch nicht mit einer Seriendruckquelle verbunden."
           Exit Sub
        End If
   
    'Anzahl Datensätze feststellen, Abbruch bei 0
    anzahl = .DataSource.RecordCount
   
        If anzahl = 0 Then
            MsgBox "Es wurden keine Datensätze gefunden."
            Exit Sub
        End If
       
    .Destination = wdSendToNewDocument
   
        For i = 1 To anzahl
            With .DataSource
             .ActiveRecord = i
             
               If fso.FolderExists(strStartordner & Format(.DataFields("Termin"), "dd.mm.yyyy")) Then
                   Set Datumsordner = fso.GetFolder(strStartordner & Format(.DataFields("Termin"), "dd.mm.yyyy"))
               Else
                   Set Datumsordner = fso.CreateFolder(strStartordner & Format(.DataFields("Termin"), "dd.mm.yyyy"))
              End If
             
            strNamensordner = Datumsordner & "\" & .DataFields("Vorname") & "_" & .DataFields("Nachname")
           
             If fso.FolderExists(strNamensordner) Then
                Set namensOrdner = fso.GetFolder(strNamensordner)
             Else
                Set namensOrdner = fso.CreateFolder(strNamensordner)
             End If
                   
             strDateiname = namensOrdner & "\" & .DataFields("Nachname").Value & "_" & .DataFields("Vorname").Value
           
             'macht dem Seriendruck vor, dass es bei jedem Durchgang nur 1 Datensatz gibt
             .FirstRecord = i
             .LastRecord = i
          End With
          .Execute
         
          With ActiveDocument
              'Schönheitssache: löscht den abschließenden Abschnittsumbruch
              .Range.Find.Execute findtext:="^b", replacewith:=""
             
              'Speichern als .docx
              .SaveAs FileName:=strDateiname & ".docx"
              .Close
          End With
        Next i
       
    .DataSource.FirstRecord = 1
End With
MsgBox anzahl & " Dateien erstellt."
End Sub

 

Funktioniert einwandfrei

Vielen Dank!

 

Hallo zusammen,
Ich würde mich hier einfach mal mit ranhängen, weil das genau das ist was ich brauche :)

Ich hab den Code mehr oder weniger so übernommen, nur die Titel der Ordner angepasst. Leider bekomme ich jedesmal für

Code:

               Else
                   Set zielOrdner = fso.CreateFolder(pfad & .DataFields("Nachname"))

einen Laufzeitfehler 76 "Pfad nicht gefunden"

Mein Kompletter Code sieht so aus:

Code:

Sub JederDatensatzInEinenEigenenOrdner()
Dim i As Long, anzahl As Long
Dim pfad As String, dateiname As String
Dim fso As Object, zielOrdner As Object

Set fso = CreateObject("Scripting.FileSystemObject")
pfad = "C:\My Stuff\Projekte\Klunkerkranich\Personal_(Server)\test\" '*** das ist der Startordner -  anpassen

If Not fso.FolderExists(pfad) Then
    MsgBox "Bitte Startordner anlegen"
    Exit Sub
End If

With ActiveDocument.MailMerge
        If .MainDocumentType = wdNotAMergeDocument Then
           MsgBox "Das Dokument ist noch nicht mit einer Seriendruckquelle verbunden."
           Exit Sub
        End If
  
    'Anzahl Datensätze feststellen, Abbruch bei 0
    anzahl = .DataSource.RecordCount
  
        If anzahl = 0 Then
            MsgBox "Es wurden keine Datensätze gefunden."
            Exit Sub
        End If
      
    .Destination = wdSendToNewDocument
  
        For i = 1 To anzahl
            With .DataSource
             .ActiveRecord = i
            
               If fso.FolderExists(pfad & .DataFields("Nachname")) Then
                   Set zielOrdner = fso.GetFolder(pfad & .DataFields("Nachname"))
               Else
                   Set zielOrdner = fso.CreateFolder(pfad & .DataFields("Nachname"))
              End If
          
             dateiname = zielOrdner & "\" & .DataFields("Nachname").Value & "_" & .DataFields("Vorname").Value
          
             'macht dem Seriendruck vor, dass es bei jedem Durchgang nur 1 Datensatz gibt
             .FirstRecord = i
             .LastRecord = i
          End With
          .Execute
        
          With ActiveDocument
              'Schönheitssache: löscht den abschließenden Abschnittsumbruch
              .Range.Find.Execute findtext:="^b", replacewith:=""
            
              'Speichern als .docx
              .SaveAs FileName:=dateiname & ".docx", AddToRecentFiles:=False
              .Close
          End With
        Next i
      
    .DataSource.FirstRecord = 1
End With
MsgBox anzahl & " Dateien erstellt."
End Sub

Freu mich über jeden Tip, danke!

 

Hallo Gorgor,

mein Hauptverdacht geht dahin, dass es in deiner Datenquelle keine Spalte mit der Überschrift "Nachname" gibt (hier kommts auch auf Groß- und Kleinschreibung an!)
Mein zweiter Verdacht, dass was mit dem Pfad nicht stimmt. Prüfe das so, indem du direkt über If fso.Folderexists(pfad & .DataFields("Nachname")) eine Messagebox setzt:
msgbox pfad & .DataFields("Nachname") Stimmt der? Keine doppelten oder fehlenden Backslashes?

Wenn keins von beiden zutrifft, bräuchte es ein Muster deines Hauptdokuments und eins deiner Datenquelle mit mindestens 2 (natürlich fingierten) Datensätzen