VBA - Email multiple people with different attachments

[x3AnnieY]

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)

To	CC	Body	Attachment
example1@hotmail.com	cc1@mail.com; cc2@mail.com; cc3@mail.com	Example Body	C:\Users\Desktop\Example.xls
example2@hotmail.com	cc4@mail.com; cc5@mail.com; cc6@mail.com	Example Body	C:\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:

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

 

[wideboydixon]

Small modifications here:

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]

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]

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]

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]

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]

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]

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!

 

[gpapa]

Hello,
This code works great. The only problem I am running into is that my default signature is not being included in the email. What would I need to modifly to include this feature?