Send multiple different pdf to contacts on list

Hi! Im new here and really looking forward to learn about vba , in the meantime, I wanted to ask your kind help in order to sort this out.
I receive several different pdf files on outlook, the subject will always be the invoice number, then customers name.

I have an excel list , and what I want to achieve is basically run a macro so that way it will search for a file within a folder (files are named after the emails subject) then attach it and send it to the contact person on the list.


So far I have the following code:



Sub macro()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim fso
Dim file As String


For I = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)

With olMail
.To = Cells(I, 1).Value
.subject = Cells(I, 2).Value
.body = Cells(I, 3).Value
.Attachments.Add Range("D2").Value & "\" & Range("E2").Value & ".pdf"
.Send

End With

Next

End Sub

But the thing s all I have been able to achieve is to send emails with the same file attached (in this case the file on E2)
Anything you guys can suggest ? running out of options

Welcome to the forum! I am unclear on some things. Are you wanting to send one email per unique Recipent with all files in Path and filename in Subject? Or?

Thats correct , every line is a customer , every line contains one single file to be sent.

Yes but your thread says send multiple files. From what you posted, I gleamed that you meant for a macro to get unique emails, do a multiple find or filter for each unique one, and then build the file list accordingly.

One of the best ways to get help is to include a small sample obfuscated file. You can do so by clicking the bottom right of a reply Go Advanced button, and then the paperclip icon, and then Browse and Upload. If what I surmised is correct, even that won't be needed though your Subject and Body fields do not match the fields/column headings in your picture. Of course that means that Subject and Body would have to come from the first row found.

At some point, the macro may need to see if each file in the unique email rows exist. That can be handled later if needed.

Keneth
Hope this one helps, thanks in advance for your help.

I used the Filter method and dded another column:
To, Subject, Body, Path, PDFname

Code:

---

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

---