Option Explicit

Sub Split_the_Merge()
'
' Split_the_Merge Macro
'
'
' Save each single Mail Merge Record into a seperate Document
'
Dim rec, lastRecord As Integer

Dim docFileFormat, docNameField, strDocName, savePath, savePathPDF, scriptstr, scripstrPDF As String

' Choose Folder dialog (Mac or Windows)

#If Mac Then
    #If MAC_OFFICE_VERSION < 15 Then
        scriptstr = "(choose folder with prompt ""Select the Output folder"") as string"
    #Else
        scriptstr = "return posix path of (choose folder with prompt ""Select the Output folder"") as string"
    #End If
    savePath = MacScript(scriptstr)

#Else 'Windows
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then
            savePath = .SelectedItems(1) & Application.PathSeparator
        End If
    End With
    'savePath = ActiveDocument.Path & "\Files\"
#End If

' If a destination folder has been selected

If savePath <> "" Then
    ' Turn off some visuals to speed things up a bit
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' Find the last record of the Mail Merge data
    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
    lastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
    
    ' Ask for user confirmation to start creating the documents
    If MsgBox(lastRecord & " Records will be processed based on your Mail Merge template.", vbOKCancel) = vbOK Then
        ' Ask for the name of the Merge Field name to use for the document names
        docNameField = InputBox("Which Mergefield should be used for document name?", "Filename?", "Filename")
        If MsgBox("Do you want to generate .docx & .pdf files?", VBA.VbMsgBoxStyle.vbQuestion + VBA.VbMsgBoxStyle.vbYesNo) = vbYes Then
            docFileFormat = "both"
            savePathPDF = savePath & "__PDF"
            MakeFolderIfNotExist (savePathPDF)
            savePathPDF = savePathPDF & Application.PathSeparator
        ElseIf MsgBox("Do you want to only generate .pdf files?", VBA.VbMsgBoxStyle.vbQuestion + VBA.VbMsgBoxStyle.vbYesNo) = vbYes Then
            docFileFormat = "wdFormatPDF"
            MakeFolderIfNotExist (savePath & "__PDF")
            savePathPDF = savePath & "__PDF" & Application.PathSeparator
        End If

        ' Create document for each Mail Merge record (loop)
        For rec = ActiveDocument.MailMerge.DataSource.FirstRecord To lastRecord
            With ActiveDocument.MailMerge
                .Destination = wdSendToNewDocument
                With .DataSource
                    .FirstRecord = rec
                    .lastRecord = rec
                    .ActiveRecord = rec
                    
            ' Set document name for current record
                    If Trim(docNameField) = "" Or Trim(.DataFields(docNameField).Value) = "" Then
                        strDocName = "document" & rec
                    Else
                        strDocName = .DataFields(docNameField).Value
                    End If
            
                End With
            ' Execute Mail Merge action
                .Execute Pause:=False
            End With
            If docFileFormat = "both" Then
            ' Save generated document as .docx and .pdf and close it after saving
                ActiveDocument.SaveAs fileName:=savePath & strDocName & ".docx"
                ActiveDocument.SaveAs fileName:=savePathPDF & strDocName & ".pdf", fileFormat:=wdFormatPDF
            ElseIf docFileFormat = "wdFormatPDF" Then
            ' Save only .pdf
                ActiveDocument.SaveAs fileName:=savePathPDF & strDocName & ".pdf", fileFormat:=wdFormatPDF
            Else
            ' Save only .docx
                ActiveDocument.SaveAs fileName:=savePath & strDocName & ".docx"
            End If

            ActiveDocument.Close SaveChanges:=False
            'ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
        Next rec
        
        ' Re-enable screen visuals
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True

        'Inform User of results
        MsgBox (lastRecord & " Records have been processed and files have been generated according to your preferences")
         With ActiveDocument.MailMerge
                .Destination = wdSendToNewDocument
                With .DataSource
                    .FirstRecord = 1
                    .lastRecord = rec - 1
                    .ActiveRecord = 1
                End With
        End With

    Else 'if no destination folder was selected
        'Re-enable screen visuals
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Exit Sub
    End If
End If
End Sub

Function MakeFolderIfNotExist(Folderstring As String)
'Ron de Bruin, 22-June-2015
' http://www.rondebruin.nl/mac/mac010.htm
    Dim ScriptToMakeFolder As String
    Dim str As String
    #If Mac Then 'If we are operating on a Mac
        #If MAC_OFFICE_VERSION < 15 Then
            ScriptToMakeFolder = "tell application " & Chr(34) & _
                                 "Finder" & Chr(34) & Chr(13)
            ScriptToMakeFolder = ScriptToMakeFolder & _
                    "do shell script ""mkdir -p "" & quoted form of posix path of (" & _
                            Chr(34) & Folderstring & Chr(34) & ")" & Chr(13)
 
           ScriptToMakeFolder = ScriptToMakeFolder & "end tell"

            On Error Resume Next

            MacScript (ScriptToMakeFolder)

            On Error GoTo 0
        #Else

            str = MacScript("return POSIX path of (" & _
                            Chr(34) & Folderstring & Chr(34) & ")")
            'str = MacScript("return path of (" & _
                            Chr(34) & Folderstring & Chr(34) & ")")

            MkDir str

        #End If

    #Else ' We are operating on a windows machine
        On Error Resume Next
        MkDir Folderstring
        On Error GoTo 0
    #End If

End Function