Send multiple different pdf to contacts on list

[Kenneth Hobs]

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