Determine number of mailmerge records

[Craig Norton]

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.

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

[Guessed]

Can you adapt this looping code to fit your requirements? Start by testing it by itself before you start adding your extra code. It appears you have code included in your sample which may not be required with this approach.

Public Sub Merge_To_Individual_Files()
  Dim StrFolder As String, MainDoc As Document, i As Long
  Set MainDoc = ActiveDocument
  StrFolder = MainDoc.Path & "\"
  With MainDoc.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    .ViewMailMergeFieldCodes = False
    With .DataSource
      .ActiveRecord = wdFirstRecord
      Do Until i = .ActiveRecord  'next record didn't go forward
        MainDoc.SaveAs FileName:=StrFolder & i & "temp.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        i = .ActiveRecord
        .ActiveRecord = wdNextRecord
      Loop
    End With
  End With
End Sub