Determine number of merge records instead of records in Data Source

I have the below code which 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()
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
        'StrFolder = .DataFields("Folder") & "\"
        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