Hi.
I have the below code which I got from this site and it produces individual PDFs. When it runs it cycles through all merge records in the Data Source. The issue I have is that we apply a filter when opening and it may only select say 10 records of the total data source of 200 records. Is there a way to determine the number of merge records (e.g. 10) instead of using datasource.RecordCount which returns 200. The issue is that it continues to cycle through the entire Data Source which takes longer compared to just the actual records being merged.
Code:
Public Sub Merge_To_Individual_Files()
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\Email Attachments\"
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("securitycode")) = "" Then Exit For
StrName = "W-8BEN Form" & " - " & .DataFields("Portfoliocode") & " " & .DataFields("securitycode") & " " & .DataFields("name")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
MsgBox ("PDFs have been created.")
End Sub