VBA to Send Mass Emails with Individual Attachments

[MrMaker]

Hi all,

I need some VBA to allow me to send multiple emails (same standard email body but each with their own individual Excel attachment).

I'm using Microsoft Outlook and Excel 365

Workbook Entitled: 'Raw Data'
Sheet Entitled 'Sheet1'
Column A: Email Address
Column B: First Name (for email greeting)
Column C: Attachment Path (.xlsx files to be sent)

The Email Body has some text and a couple of links, so I can set up a message template if easier?

Any help would be much appreciated, nothing I have found online to date appears to work

Thank you

 

[DanteAmor]

In the cells of column C you have something like this:

c:\job\books\bookxd.xlsx

That is, you have the folder and the file name, if so then try this:

Sub Send_Mass_Emails()
  Dim dam As Object, i As Long, sFile As String
  
  For i = 2 To Range("a" & Rows.Count).End(3).Row
    Set dam = CreateObject("outlook.application").createitem(0)
    dam.To = Range("A" & i).Value
    dam.Subject = "Subject " & Range("B" & i).Value
    dam.body = "The Email Body has some text and a couple of links "
    sFile = Range("C" & i).Value
    If Dir(sFile) <> "" Then dam.Attachments.Add
    dam.Display 'change to .Send to send
  Next
End Sub

 

[MrMaker]

Thank you for your reply.

I am getting 'Automation Error' when I run it though?

 

[DanteAmor]

Run the macro again and when the error appears press the "Debug" button and write here which line is highlighted in yellow.
What else does the error say?

 

[MrMaker]

No debug error just the below box:

 

[DanteAmor]

Maybe it's the excel version, wait for someone to put a code for office 365.

 

[ManiacB]

Try this code:

Sub Macro_email()  
   Dim rng As Range, Cell As Range, I As Long, DataRow As Long
   
   Set rng = Worksheets("BOOKING").Range("D6,D8,D10,D13,D15,D17,D19,D20")
   ' DataRow = Worksheets("MHELOAN").Columns(1).Find(What:=vbNullString, LookAt:=xlWhole, After:=Worksheets("MHELOAN").Cells(2, 1)).Row
   
   I = 1
   For Each Cell In rng
     ' Worksheets("MHELOAN").Cells(DataRow, I) = Cell.Text
      I = I + 1
   Next Cell
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = " COLLECTION REQUEST" & vbNewLine & vbNewLine & _
              "PLEASE BE ADVISED  BE COLLECTED" & vbNewLine & _
              "PLEASE CAN YOU MAKE ARRANGEMENT TO COLLECT AND PROCESSED"
                  On Error Resume Next
    With xOutMail
        .To = "team"
        .CC = ""
        .BCC = ""
        .Subject = "COLLECTION REQUEST"
        '.HTMLBody = RangetoHTML(rng)
        .Body = xMailBody & rng
        .display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

 

[Ron de Bruin]

you can test the code on this page if you want : Mail a different file(s) to each person in a range