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!!
 

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

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
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
365, 2019
Platform
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
2016
Platform
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.
 

Forum statistics

Threads
1,089,218
Messages
5,406,923
Members
403,113
Latest member
ms_excel_recal_or_die

This Week's Hot Topics

Top