VBA to attach file and send to multiple recipients and then loop for a list

[JONTYH26]

Hello

I am trying to get VBA to create an email, add a 'To' address, a 'Cc' address, attach a file based on a file path and loop through a list to create an email for every row in a list for different people with unique files.

For example

To	Cc	Bcc	File
Director@company1.com	Manager@company1.com		C:/Documents/Company1File.pdf
Finance@company2.com	Finance2@company2.com		C:/Documents/Company2File.pdf
HR@company3.com	HRManager@company3.com		C:/Documents/Company3File.pdf
Legal@company4.com	Solicitor@Legal.com		C:/Documents/Company4File.pdf

<tbody>
</tbody>

Sub SendFiles()


    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:C").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 = Range("B1:").Value
                .cc = Range("C1:").Value
                .Subject = "Testfile"
                .Body = "Hi " & vbNewLine & _
                "this is a test" _
                
                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


               .Display
            End With


            Set OutMail = Nothing
        End If
    Next cell


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

I can't get the code to work through each line and create a new email.

Any help appreciated.

thanks

 

[DanteAmor]

Assuming that your data is like this:


<table border="1" cellspacing="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:76.04px;" /><col style="width:213.86px;" /><col style="width:199.6px;" /><col style="width:33.27px;" /><col style="width:296.55px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td > </td><td >TO</td><td >CC</td><td > </td><td >FILE</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td > </td><td >Director@company1.com</td><td >Manager@company1.com</td><td > </td><td >C:\Documents\Company1File.pdf</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td > </td><td >Finance@company2.com</td><td >Finance2@company2.com</td><td > </td><td >C:\Documents\Company2File.pdf</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td > </td><td >HR@company3.com</td><td >HRManager@company3.com</td><td > </td><td >C:\Documents\Company3File.pdf</td></tr><tr style="height:19px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td > </td><td >Legal@company4.com</td><td >Solicitor@Legal.com</td><td > </td><td >C:\Documents\Company4File.pdf</td></tr></table>

Try this:

Sub SendFiles()
    Dim OutApp As Object, sh As Worksheet, cell As Range


    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Range("B2", sh.Range("B" & Rows.Count).End(xlUp))
        If cell.Value Like "?*@?*.?*" Then
            With OutApp.CreateItem(0)
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .Subject = "Testfile"
                .Body = "Hi " & vbNewLine & _
                    "this is a test"
                If Dir(cell.Offset(0, 3).Value) <> "" Then .Attachments.Add cell.Offset(0, 3).Value
               .Display
            End With
        End If
    Next cell
    Set OutApp = Nothing
End Sub

 

[JONTYH26]

Works a treat!

Much obliged.

 

[DanteAmor]

Works a treat!

Much obliged.

I'm glad to help you. Thanks for the feedback.

 

[JONTYH26]

One more thing I would like help with is conroling the subject of the email based on data in column b. The data is different in every line but i would like this in the subject.

thanks

Sub PrepareEmails() Dim OutApp As Object, sh As Worksheet, cell As Range




Set sh = Sheets("Contact")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Range("b2", sh.Range("b" & Rows.Count).End(xlUp))
lastrow = ActiveWorkbook.Sheets("Contact").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If cell.Value Like "?*@?*.?*" Then
With OutApp.CreateItem(0)
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.bcc = cell.Offset(0, 2).Value
.Subject = "Provision Map 2019-20" & ActiveWorkbook.Sheets("Contact").Range("b" & i).Value
.Body = "Dear Colleague " & vbNewLine & vbNewLine & _
"Please find attached the Budget" _


If Dir(cell.Offset(0, 3).Value) <> "" Then .Attachments.Add cell.Offset(0, 3).Value

.Save

End With
End If
Next Cell
MsgBox "E-mail Successfully Drafted"
Set OutApp = Nothing
End Sub

 

[DanteAmor]

One more thing I would like help with is conroling the subject of the email based on data in column b. The data is different in every line but i would like this in the subject.

thanks

Try this

Change "B" for the column where you have the subject.

Sub SendFiles()
    Dim OutApp As Object, sh As Worksheet, cell As Range




    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Range("B2", sh.Range("B" & Rows.Count).End(xlUp))
        If cell.Value Like "?*@?*.?*" Then
            With OutApp.CreateItem(0)
                .to = cell.Value
                .cc = cell.Offset(0, 1).Value
                .Subject = cells(cell.row, "[COLOR=#ff0000][B]B[/B][/COLOR]").value
                .Body = "Hi " & vbNewLine & _
                    "this is a test"
                If Dir(cell.Offset(0, 3).Value) <> "" Then .Attachments.Add cell.Offset(0, 3).Value
               .Display
            End With
        End If
    Next cell
    Set OutApp = Nothing
End Sub