Mail Merge Macro - Saves to PDF/Word

[Rob_010101]

Hello

I use a macro to save mail merged documents into word and PDF files; very handy.

I must select all the rows above the row I need in the recipient list for it to work. If I only ticked "Sam" and left "Connor" and "Vincent" unticked, the macro will produce a "runtime error 5631" on

.Execute Pause:=False

Visa versa, if I ticked "Connor" and left "Sam" unticked, as long as "Vincent" is ticked, the macro will work.

This is unmanageable with 1000's of rows. The macro takes ages to run and I then have to delete all the documents I don't need after.

Is it possible to fix the below so it will run on any row/rows I have selected in the recipient list, regardless of if the leading rows are selected?

Sub Split_2_PDF()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        If .Show = -1 Then
            For Each vrtSelectedItem In .SelectedItems
                SelectedPath = vrtSelectedItem
            Next vrtSelectedItem
        Else
            MsgBox ("No Directory Selected.  Exiting")
            Exit Sub
        End If
    End With
    Set fd = Nothing
    Application.ScreenUpdating = False
    MainDoc = ActiveDocument.Name
    ChangeFileOpenDirectory SelectedPath
    For i = 1 To ActiveDocument.MailMerge.DataSource.RecordCount
        With ActiveDocument.MailMerge
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = i
                .LastRecord = i
                .ActiveRecord = i
                docname = .DataFields("File_Name")
            End With
            .Execute Pause:=False
            Application.ScreenUpdating = False
        End With
        
        'export pdf
        ActiveDocument.ExportAsFixedFormat OutputFileName:=docname, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:=True, UseISO19005_1:=False
        ActiveDocument.Saved = True
        
        'export word
        ActiveDocument.SaveAs2 FileName:=docname & ".docx"
        ActiveDocument.Saved = True
        
        ActiveDocument.ActiveWindow.Close savechanges:=wdDoNotSaveChanges
        Documents(MainDoc).Activate
   Next i
    Application.ScreenUpdating = True
 
End Sub

Thanks

 

[Rob_010101]

Anyone able to help?