Send multiple different pdf to contacts on list

[esherr77]

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

[Kenneth Hobs]

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?

[esherr77]

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

[Kenneth Hobs]

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.

[esherr77]

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

[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