I used the Filter method and dded another column:
To, Subject, Body, Path, PDFname
Sub Main()
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Dim fso, file As String, i As Long, j As Long
Dim a() As Variant, r As Range, rr1 As Range, rr2 As Range
Dim aRR1() As Variant, aRR2() As Variant, sAdd As String
Set olApp = New Outlook.Application
a() = Range("A2", Range("A" & Rows.Count).End(xlUp))
a() = UniqueArrayByDict(a(), compareMethod.TextCompare) 'Unique but ignore case.
'MsgBox Join(a, vbLf)
For i = LBound(a) To UBound(a)
Range("A1").CurrentRegion.AutoFilter 1, Criteria1:=a(i), Operator:=xlAnd
Set r = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
Set r = StripFirstRow(r)
If r Is Nothing Then GoTo NextI
Set rr1 = r.Columns(4) 'Attachment file paths
Set rr2 = rr1.Offset(, 1) 'Attachment file basenames
On Error GoTo OneMatch
aRR1() = WorksheetFunction.Transpose(rr1) 'Attachment file paths
aRR2() = WorksheetFunction.Transpose(rr2) 'Attachment file basenames
For j = LBound(aRR1) To UBound(aRR1)
aRR1(j) = aRR1(j) & "\" & aRR2(j) & ".pdf"
Next j
OneMatch:
If Err.Number = 13 Then
sAdd = rr1.Value & "\" & rr2.Value & ".pdf"
On Error GoTo 0
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = rr1.Cells(1).Offset(, -3).Value 'Column A
.Subject = rr1.Cells(1).Offset(, -2).Value 'Column B
.body = rr1.Cells(1).Offset(, -1).Value 'Column C
On Error Resume Next 'Skip if file does not exist.
If rr1.Cells.Count = 1 Then
.Attachments.Add sAdd
Else
For j = LBound(aRR1) To UBound(aRR1)
.Attachments.Add aRR1(j)
Next j
End If
'.Display
.Send
End With
NextI:
Next i
EndNow:
ActiveSheet.UsedRange.CurrentRegion.AutoFilter
Set olMail = Nothing
Set olApp = Nothing
End Sub
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
Dim dic As Object 'Late Binding method - Requires no Reference
Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
'Dim dic As Dictionary 'Early Binding method
'Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End Function
Function StripFirstRow(aRange As Range) As Range
Dim i As Long, j As Long, r As Range, z As Long, idx As Long
For i = 1 To aRange.Areas.Count
For j = 1 To aRange.Areas(i).Rows.Count
z = z + 1
If z = 1 Then GoTo NextJ
If r Is Nothing Then
Set r = aRange.Areas(i).Rows(j)
Else
Set r = Union(r, aRange.Areas(i).Rows(j))
End If
NextJ:
Next j
Next i
Set StripFirstRow = r
End Function