Sending emails to multiple recipients with different file names via VBA & Excel

[merxi7]

Hi Excel Experts,

I've managed to get the below VBA working from an old (2019) thread. It creates emails to recipients for each row in a spreadsheet, customizes the email content (with the recipients name) and also attaches a file based on a file path in column E of the sheet. However, it attaches all the files in the folder. What I need is to attach only the files base on the filename in Column F.
I am very new to VBA, tried to change the code of the filename, but no luck.
Thanking you in advance for any response.

Sub SendMail()

ActiveWorkbook.RefreshAll

Dim objOutlook As Object
Dim objMail As Object
Dim Attachments 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
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
fileName = Dir(cell.Offset(0, 4).Value & "\*")
While fileName <> vbNullString
.Attachments.Add cell.Offset(0, 4).Value & "\" & fileName
fileName = Dir()
Wend
.Display
End With

Set objMail = Nothing
Next cell

Set ws = Nothing
Set objOutlook = Nothing

End Sub

 

[Sequoyah]

Hi merxi7,
I suggest you to enter in column E the complete path with the name of the attachment including the extension (e.g. C:\My Files\Customer 1.pdf) then use the following code

Sub SendMail2()
    
    ActiveWorkbook.RefreshAll
    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim Attachments As Object
    Dim ws As Worksheet
    Dim fileName As String
    Dim cell As Range
    
    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)
        fileName = cell.Offset(0, 4).Value
        
        With objMail
            .To = cell.Value
            .CC = cell.Offset(0, 1).Value
            .Subject = cell.Offset(0, 2).Value
            .Body = cell.Offset(0, 3).Value
            .Attachments.Add fileName
            .Display
        End With
        
        Set objMail = Nothing
    Next cell
    
    Set ws = Nothing
    Set objOutlook = Nothing
    
End Sub

 

[merxi7]

Hi Sequoyah, thanks for your input. However, your the above will take only pdf attachment.
Is it possible to take both pdf and xlsx formats? The file name is the same for both formats

 

[Sequoyah]

Hi merxi7,
The attachment must always be indicated with the full path and the name plus the extension. Do you always have to attach both types of files to your mail? In this case write in your cell the file name without the extension and then add it in the code, as in the following example

Sub SendMail2()
    
    ActiveWorkbook.RefreshAll
    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim Attachments As Object
    Dim ws As Worksheet
    Dim fileName As String
    Dim cell As Range
    
    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)
        fileName = cell.Offset(0, 4).Value
        
        With objMail
            .To = cell.Value
            .CC = cell.Offset(0, 1).Value
            .Subject = cell.Offset(0, 2).Value
            .Body = cell.Offset(0, 3).Value
            .Attachments.Add fileName & ".pdf"
        .Attachments.Add fileName & ".xlsx"
            .Display
        End With
        
        Set objMail = Nothing
    Next cell
    
    Set ws = Nothing
    Set objOutlook = Nothing
    
End Sub

 

[merxi7]

Hey, I was able to figure out the attachments issue.
My problem now is how can I use the non-default account for sending out emails?
I have 2 accounts in Outlook, and I tried the below code but is not working. It is still taking up the 1st account from outlook

Sub SendMail2()

ActiveWorkbook.RefreshAll

Dim objOutlook As Object
Dim objMail As Object
Dim Attachments As Object
Dim ws As Worksheet
Dim Invoice As String, Consumption As String
Dim cell As Range

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)

Path = "C:\Invoice Export\"
Invoice = Path & cell.Offset(0, 5).Value & ".pdf"
Consumption = Path & cell.Offset(0, 5).Value & ".xlsx"

With objMail
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
.Attachments.Add Invoice
.Attachments.Add Consumption
.SendUsingAccount = .Session.Accounts.Item(2)
.Display/Send
End With

Set objMail = Nothing
Next cell

Set ws = Nothing
Set objOutlook = Nothing

End Sub

 

[Sequoyah]

Hi, change the line

.SendUsingAccount = .Session.Accounts.Item(2)

with

Set .SendUsingAccount = objMail.Session.Accounts.Item(2)

 

[merxi7]

Hi, change the line

.SendUsingAccount = .Session.Accounts.Item(2)

with

Set .SendUsingAccount = objMail.Session.Accounts.Item(2)

Awesome. Thank you so much