Sending emails to multiple recipients with multiple PDF files via VBA & Excel

[The25th]

I'm very new to VBA and found a code online that sends emails to multiple recipients but can only attach 1 file per email. I cannot find a code that works wherein it goes to a specific folder and attaches all PDF files that are stored in the folder and goes to a different folder and does the same for the next email recipient. The image shows the structure of the sheet that I am working on. I'm using Office 365.

Need help please, thank you.

Here's the Excel structure:

Here's my code:

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Sub SendMail()

ActiveWorkbook.RefreshAll

Dim objOutlook AsObject
Dim objMail AsObject
Dim ws As Worksheet

Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

OnErrorGoTo MyHandler

ForEach cell In ws.Range("A2:A2000")

Set objMail = objOutlook.CreateItem(0)

With objMail
.To= cell.Value
.Cc ="email@email.com"
.Subject = cell.Offset(0,1).Value
.Body = cell.Offset(0,2).Value
.Attachments.Add cell.Offset(0,3).Value
.Display
EndWith

Set objMail =Nothing
Next cell

Set ws =Nothing
Set objOutlook =Nothing

MyHandler:
MsgBox "Review email messages"

EndSub</code>

 

[lrobbo314]

How about something like this? Change the path in the getAllFiles function for the folder that has the files you are looking to attach.

Sub SendMail()

ActiveWorkbook.RefreshAll

Dim SP() As String
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet

SP = Split(getAllFiles, ";")
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

On Error GoTo MyHandler

For Each cell In ws.Range("A2:A2000")

Set objMail = objOutlook.CreateItem(0)

With objMail
    .To = cell.Value
    .Cc = "email@email.com"
    .Subject = cell.Offset(0, 1).Value
    .Body = cell.Offset(0, 2).Value
    For i = LBound(SP) To UBound(SP)
        .Attachments.Add SP(i)
    Next i
    .Display
End With

Set objMail = Nothing
Next cell

Set ws = Nothing
Set objOutlook = Nothing

MyHandler:
MsgBox "Review email messages"

End Sub

Function getAllFiles() As String
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim sFil As Object
Dim sFol As Object
Dim res As String

Set sFol = FSO.getfolder("C:\Users\UserName\Documents\")

For Each sFil In sFol.Files
    res = res & sFol.Path & "\" & sFil.Name & ";"
Next sFil

getAllFiles = Left(res, Len(res) - 1)

End Function

 

[The25th]

Thanks, however this only captures all files from a specified folder in get files. I'm trying to get the files stored in each folder from C:\Temp"different_folders". Say folder 1 has 10 PDF files for email 1, then the 2nd folder has 5 PDF files for email 2, etc. Is there a way on getting that done? Also, I need to correct the image as I should specify "Folder Name" instead of filename.

 

[John_w]

Replace your For Each cell .... Next cell code with this:

Dim fileName as String

For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))

    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To= cell.Value
        .Cc ="email@email.com"
        .Subject = cell.Offset(0,1).Value
        .Body = cell.Offset(0,2).Value
        fileName = Dir(cell.Offset(0,3).Value & "\*.pdf")
        While fileName <> vbNullString
            .Attachments.Add cell.Offset(0,3).Value & "\" & fileName
            fileName = Dir()
        Wend
        .Display
    EndWith

    Set objMail = Nothing
Next cell

 

[The25th]

The code did not capture the files in the separate folders, it just created the email without the attachment. What did I do wrong, please help? Here's the code:

Sub SendMail()

ActiveWorkbook.RefreshAll

Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Dim fileName As String


Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

On Error GoTo MyHandler


For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))


Set objMail = objOutlook.CreateItem(0)


With objMail
.To = cell.Value
.Cc = "email@email.com"
.Subject = cell.Offset(0, 1).Value
.Body = cell.Offset(0, 2).Value
fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
While fileName <> vbNullString
.Attachments.Add cell.Offset(0, 3).Value & "" & fileName
fileName = Dir()
Wend
.Display
End With


Set objMail = Nothing
Next cell


Set ws = Nothing
Set objOutlook = Nothing


MyHandler:
MsgBox "Review email message"


End Sub

 

[John_w]

You didn't apply or post my code correctly (use CODE tags - the # icon in the message editor). It should be:

fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
            While fileName <> vbNullString
                .Attachments.Add cell.Offset(0, 3).Value & "\" & fileName
                fileName = Dir()
            Wend

Column D is expected to be the full folder path of the folder containing .pdf files to be attached, for example D2 "C:\TEMP\202761" contains .pdf files. There should be no trailing back slash on the path.

Also, delete the On Error GoTo line, or put a comment character (apostrophe) at the start of the line, and run the macro and see if an error occurs.

 

[The25th]

Thank you so much! It now work, a small hiccup though. The email keeps on creating even though the list ends. How do I stop the code when the list ends?

 

[The25th]

Thank you so much! It now work, a small hiccup though. The email keeps on creating even though the list ends. How do I stop the code when the list ends?

Here's the full working code (I removed the CC part):

Sub SendMail()

    ActiveWorkbook.RefreshAll
    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim ws As Worksheet
    Dim fileName As String


    Set objOutlook = CreateObject("Outlook.Application")
    Set ws = ActiveSheet
    
  For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))


    Set objMail = objOutlook.CreateItem(0)


        With objMail
            .To = cell.Value
            .Subject = cell.Offset(0, 1).Value
            .Body = cell.Offset(0, 2).Value
            fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
                        While fileName <> vbNullString
                            .Attachments.Add cell.Offset(0, 3).Value & "\" & fileName
                            fileName = Dir()
                        Wend
            .Display
        End With


        Set objMail = Nothing
    Next cell


    Set ws = Nothing
    Set objOutlook = Nothing




End Sub

 

[John_w]

Your code looks correct, though add this line in the Dims:

    Dim cell As Range

The line

For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))

loops from A2 to the last populated cell in column A (i.e. the end of the list of emails), so the macro should end when the list ends.

Make sure the sheet you showed in your OP is the active sheet when you run the macro, because the code assigns ActiveSheet to the ws object.

 

[The25th]

Awesome, all good now. Thank you!