VBA to Send Mass Emails with Individual Attachments

MrMaker

New Member
Joined
Jun 7, 2018
Messages
33
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
 

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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:

VBA Code:
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

New Member
Joined
Jun 7, 2018
Messages
33
Thank you for your reply.

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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

New Member
Joined
Jun 7, 2018
Messages
33

ADVERTISEMENT

No debug error just the below box:

1600097381062.png
 

Attachments

  • 1600097360492.png
    1600097360492.png
    12.7 KB · Views: 0

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Maybe it's the excel version, wait for someone to put a code for office 365.
 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Try this code:

VBA 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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,073
Messages
5,545,827
Members
410,709
Latest member
Mrsamir
Top