Mail Merge with unique Subject, CC & Attachment using Excel & Word 2013

[Aseagz15]

Hi Excel World!

I've spent the last couple hours trying to find an answer in one of the forums regarding how to do a mail merge with a unique subject for each email from a column in Excel with no luck. I am new to VBA but understand some of the coding language used.

Simply put I would like to be able to do the following:

• Create an email using a list in excel (ie. name, address, etc.)
• CC multiple recipients (ie. email 1, email 2, email 3, email 4, etc)
• Use a subject found in a column in excel so that each email has a unique subject (I have specific subjects for each recipient so that they don't feel like they are just another email recipient)
• Attach a different PDF for each email (file path found in excel column)

PLEASE do not reference any downloads on random websites. I am looking for pure VBA code that I can utilize and modify accordingly if at all possible based on the column names that I have in my spreadsheet. Any help would be very much appreciated!

Thanks,

Aseagz15

 

[Macropod]

Mailmerge cannot do emails with CC or attachments. You need VBA code to automate Outlook for this.

The following macro automates Outlook to prepare an email. As coded, it displays, but doesn't send the email. To send, change:

    .Display
    '.Send

to:

    '.Display
    .Send

Sub CreateEmail()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet
Set xlWkSht = Worksheets("Sheet1")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
End If
With olApp
  Set olMail = .CreateItem(olMailItem)
  olMail.Display
  Set olInsp = olMail.GetInspector
  Set wdDoc = olInsp.WordEditor
  Set wdRng = wdDoc.Range
  wdRng.Text = xlWkSht.Range("E1").Text
  With olMail
    .To = xlWkSht.Range("A1").Text
    .CC = xlWkSht.Range("B1").Text
    .BCC = xlWkSht.Range("C1").Text
    .Subject = xlWkSht.Range("D1").Text
    .Attachments.Add Source:=xlWkSht.Range("F1").Text
    .Display
    '.Send
  End With
End With
ErrExit:
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

I'll leave it to you to implement whatever loops, etc. you require.

 

[Aseagz15]

Thank you so much for getting back to me! Is it possible to add the following to the VBA coding?

• How would I create a body to the message that references lines from my excel spreadsheet in the VBA code? This will allow me to create personalized messages.
• How would I include my email signature in each email that is sent?
• Can I send multiple emails with the code you provided? If so how do I go about using a list of names and emails for the merge? I tried to add this below; however, it will only send one email at a time.

Sub CreateEmail()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet
Set xlWkSht = Worksheets("Sheet1")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
End If
With olApp
  Set olMail = .CreateItem(olMailItem)
  olMail.Display
  Set olInsp = olMail.GetInspector
  Set wdDoc = olInsp.WordEditor
  Set wdRng = wdDoc.Range
  wdRng.Text = xlWkSht.Range("W2:W100").Text
  With olMail
    .To = xlWkSht.Range("J2:J100").Text
    .CC = xlWkSht.Range("G2:G100").Text
    .CC = xlWkSht.Range("H2:H100").Text
    .CC = xlWkSht.Range("I2:I100").Text
    .Subject = xlWkSht.Range("X2:X100").Text
    .Attachments.Add Source:=xlWkSht.Range("Y2:Y100").Text
    '.Display
    .Send
  End With
End With
ErrExit:
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Macropod]

As I said, "I'll leave it to you to implement whatever loops, etc. you require". I see no indication you've even attempted to implement such looping though the rows of your worksheet, for which many examples are available on this board - as well as in the many supposedly "random websites" you don't want to look at.

You can't simply specify 'xlWkSht.Range("W2:W100").Text' and expect to get the desired results. Some meaningful effort on your part, please.

 

[Aseagz15]

Although it doesn't look like it I've spent hours trying to figure this out. I'll continue to look for answers on this forum. Thanks for your help.

 

[Macropod]

Try:

Sub CreateEmails()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet, r As Long
Set xlWkSht = Worksheets("Sheet1")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
End If
With olApp
  Set olMail = .CreateItem(olMailItem)
  olMail.Display
  Set olInsp = olMail.GetInspector
  Set wdDoc = olInsp.WordEditor
  Set wdRng = wdDoc.Range
  For r = 2 To xlWkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    wdRng.Text = xlWkSht.Range("W" & r).Text
    With olMail
      .To = xlWkSht.Range("J" & r).Text
      .CC = xlWkSht.Range("G" & r).Text & "; " & xlWkSht.Range("H" & r).Text & "; " & xlWkSht.Range("I" & r).Text
      .Subject = xlWkSht.Range("X" & r).Text
      .Attachments.Add Source:=xlWkSht.Range("Y" & r).Text
      .Display
      '.Send
    End With
  Next
End With
ErrExit:
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

As you can see, there's nothing complicated about implementing a loop.

 

[Aseagz15]

Thank you Paul! This is now doing everything I want it to, the only thing I'm working on now is adding the signature line. I also adjusted the loop code so that it creates each individual email like I want it to. Thank you for your help!