Option Explicit


Sub MailMerge_Automation()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Oct 2020
Dim FOLDER_SAVED As String
Dim SOURCE_FILE_PATH As String
Dim FSO As Object
Dim MainDoc As Document, TargetDoc As Document
Dim dbPath As String
Dim strName As String
Dim recordNumber As Long, totalRecord As Long
Dim arrInvalid() As String
Dim lng_Index As Long

    FOLDER_SAVED = Environ("USERPROFILE") & "\Desktop\PhotoRelease\"
    SOURCE_FILE_PATH = Environ("USERPROFILE") & "\Desktop\PhotoRelease\ScoutRoster.xls"
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")


    If Documents.Count = 0 Then
        MsgBox "No document open!", vbCritical
        Exit Sub
    End If

    If ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument Then
        MsgBox "The current document is not a mailmerge document!", vbCritical
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Not FSO.FolderExists(FOLDER_SAVED) Then
        MsgBox "The folder" & vbCr & FOLDER_SAVED & vbCr & "does not exist!", vbCritical
        Exit Sub
    End If

    If Not FSO.FileExists(SOURCE_FILE_PATH) Then
        MsgBox "The workbook" & vbCr & SOURCE_FILE_PATH & vbCr & "is not present!", vbCritical
        Exit Sub
    End If

    Set MainDoc = ActiveDocument
    With MainDoc.MailMerge
        .OpenDataSource Name:=SOURCE_FILE_PATH, _
                        ConfirmConversions:=False, _
                        ReadOnly:=False, _
                        LinkToSource:=True, _
                        AddToRecentFiles:=False, _
                        Format:=wdOpenFormatAuto, _
                        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & _
                                    SOURCE_FILE_PATH & _
                                    ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=35;Jet OLE" _
                                    , SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:= _
                        wdMergeSubTypeAccess

        totalRecord = .DataSource.RecordCount
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True

        For recordNumber = 1 To totalRecord
            With .DataSource
                .FirstRecord = recordNumber
                .LastRecord = recordNumber
                .ActiveRecord = recordNumber

                strName = .DataFields("Name").value

                MainDoc.MailMerge.Execute Pause:=False

                Set TargetDoc = ActiveDocument
                If Not strName = "" Then
                    TargetDoc.SaveAs2 FOLDER_SAVED & strName & ".docx", wdFormatDocumentDefault
                    TargetDoc.ExportAsFixedFormat FOLDER_SAVED & strName & ".pdf", ExportFormat:=wdExportFormatPDF
                Else
                    MsgBox "There is no filename available for this record!", vbCritical
                End If
                TargetDoc.Close 0
NextRecord:
            End With
            DoEvents
        Next recordNumber
    End With

    Set MainDoc = Nothing
    Set TargetDoc = Nothing
    Set FSO = Nothing
End Sub