VBA - Email multiple people with different attachments

x3AnnieY

New Member
Joined
Dec 12, 2017
Messages
2
Hi All,

This is the first time I'm posting on this forum and I'm a Macro dummy right now so I need some help.

I have a list of 200+ emails which I would need to send individual emails to as they require different attachment for them.

Here is what I have:
Column A - To Email
Column B - CC Emails
Column C - Body
Column D - Attachment (File Path)

ToCCBodyAttachment
example1@hotmail.comcc1@mail.com; cc2@mail.com; cc3@mail.comExample BodyC:\Users\Desktop\Example.xls
example2@hotmail.comcc4@mail.com; cc5@mail.com; cc6@mail.comExample BodyC:\Users\Desktop\Example2.xls

<tbody>
</tbody>
What I need the VBA to do is to send A1 and CC B1 with C1 Body and with D1 attachment.


Here is my current code:
VBA Code:
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set sh = Sheets("Sheet1")


    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)


        'Enter the path/file names in the D:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")


        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)


            With OutMail
                .to = ThisWorkbook.Sheets("Sheet1").Range("A1").Value
                .CC = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
                .Subject = "Example Subject 1"
                .Body = ThisWorkbook.Sheets("Sheet1").Range("C1").Value


                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell


                .Send  'Or use .Display/Send
            End With


            Set OutMail = Nothing
        End If
    Next cell


    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

The current code does not send the emails properly and I can't figure whether is my range format incorrect. When i run the code, it will send the email however it will only send to A1 and B1 recipients with Attachments from both D1 and D2.

Also, is there a way to just point the body to one single cell for all e-mails? The body would stay the same for all 200+ emails so I would only need one cell to do this.

Please help me out! If not i would have to manually send out 200+ emails!!
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

wideboydixon

Well-known Member
Joined
Jun 2, 2016
Messages
3,401
Small modifications here:

Code:
Sub Send_Files()

'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)

    'Enter the path/file names in the D:Z column in each row
    Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")
    
    If cell.Value Like "?*@?*.?*" And _
    Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)
        
        With OutMail
            .to = sh.Cells(cell.Row, 1).Value
            .CC = sh.Cells(cell.Row, 2).Value
            .Subject = "Example Subject 1"
            .Body = sh.Cells(cell.Row, 3).Value
            
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            
            .Send 'Or use .Display/Send
        End With
        
        Set OutMail = Nothing
    End If
Next cell

Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

WBD
 

x3AnnieY

New Member
Joined
Dec 12, 2017
Messages
2
YAY!

Thank you. It seems to work fine now.

Thank you for help although it is just a small modification. I'm far from knowing code language well :)
 

yujy19

New Member
Joined
Jan 15, 2019
Messages
1
Hello,
I was looking for a code just like the above with the small distinction that i want to add all files in set folder (range D:Z). Is there any way to change the code?
As a note i'm a total noob when it comes to VBA.
Thank you in advance.
Cheers,
 

Sneak_Cat

New Member
Joined
Mar 19, 2019
Messages
1

ADVERTISEMENT

Hi

I am trying to have a formula driven "To" with a Vlookup - is there anyway of embedding code so that it replaces the email address with text whilst running the macro so that the original spreadsheet is left intact?
I have managed to write it as a different process but I don't want to permanently overwrite all the values?

Thanks
 

Jemx

New Member
Joined
Feb 28, 2020
Messages
1
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
This is really very helpful. I assigned the script to a button. After clicking it, mistakenly push the button twice. How can you add a message box saying "are you sure you want to send the emuals?" then if you click OK it will proceed sending the email and when you click Cancel, it will not send. I'm very new to this, and really need assistance. Thank you.
 

KennyBrace

New Member
Joined
Mar 25, 2020
Messages
1
Office Version
  1. 2016
Platform
  1. Windows
This works great. Is there a way to have the body of the email copied from a word document or an .msg file? I want my email message to have some pictures attached.
 

dumitruflorinandrei

New Member
Joined
Jan 12, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi!

I am trying to use this code on Excel 365 and I am receiving error 53 - File not found and if I go to debug it highlights:
If Dir(FileCell.Value) <> "" Then

It is not working in excel 365? Is there any chance to make it work?

Thank you!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,383
Messages
5,635,942
Members
416,889
Latest member
dhegs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top