Sub aaaaSerienbrief()
    ' set variables
    Dim iBrief As Integer, sBrief As String
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Dim Path As String
    
    ' catch any errors
    On Error GoTo ErrorHandling
    
    ' determine path
    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Speicherort für Serienbriefe auswählen", 0, 16) _
 _
 _
 _

    
    If BrowseDir = "Desktop" Then
        Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Else
        Path = BrowseDir.items().Item().Path
    End If
    
    If Path = "" Then GoTo ErrorHandling
        
    Path = Path & "\Serienbrief-" & Format(Now, "dd.mm.yyyy-hh.mm.ss") & "\"
    MkDir Path
    
    On Error GoTo ErrorHandling
        
    ' hide application for better performance
    MsgBox "Serienbriefe werden exportiert. Dieser Vorganag kann einige Minuten dauern -  _
Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
    Application.Visible = False
 
    ' create bulkletter and export as docx
    With ActiveDocument.MailMerge
        .DataSource.ActiveRecord = 1
        Do
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = .ActiveRecord
                .LastRecord = .ActiveRecord
                sBrief = Path & .DataFields("ID").Value & ".docx"
            End With
            .Execute Pause:=False
        
            If .DataSource.DataFields("ID").Value > "" Then
                ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatdocx
            End If
            ActiveDocument.Close False
        
            If .DataSource.ActiveRecord < .DataSource.RecordCount Then
                .DataSource.ActiveRecord = wdNextRecord
            Else
                Exit Do
            End If
        Loop
    End With
    
    ' error handling
ErrorHandling:
    Application.Visible = True
 
    If Err.Number = 76 Then
        MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
    ElseIf Err.Number = 5852 Then
        MsgBox "Das Dokument ist kein Serienbrief"
    ElseIf Err.Number = 4198 Then
        MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
    ElseIf Err.Number = 91 Then
        MsgBox "Exportieren von Serienbriefen abgebrochen", vbOKOnly + vbExclamation
    ElseIf Err.Number > 0 Then
        MsgBox "Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.",  _
vbOKOnly + vbCritical
    Else
        MsgBox "Serienbriefe erfolgreich exportiert", vbOKOnly + vbInformation
    End If
End Sub