Macro for Mail Merge with CC and Attachments

[anantashesh]

Hi,

Have been using the forums for a long time for various excel related tips and help. However I cannot find a solution to my current problem and want your help.

I have to mail multiple people, both in "To" and "CC", with each mail containing a separate PPT. Now, I have found macros for mail merge with CC and mail merge with attachments. What I am looking for is a combination of both.

Ideally what I would like the Macro to do is pick multiple "To" from one column, "CC" from another column and give me a pop up window asking me to attach the PPT for each mail.

Any help in this direction will be greatly appreciated.

Thanks!!!

 

[adam087]

Hi. Welcome to the board

What code do you have so far?
And what email client are you using?

/AJ

 

[anantashesh]

Hi Adam,

To be honest, I don't have any working code for what I am looking for. I have tried tweaking the code found at Merging With Attachments. But it is a Word Macro and I am not able to use it properly.

I am very new to macros and my knowledge is very limited in this area.

Please let me know what else I can do for a solution to my problem.

 

[adam087]

OK. This code appears to compile but alas I can't test it because we use Lotus Notes at work (don't ask) and from that link it looks like you want it for Outlook?

Well give this a go and see if it works for you

Option Explicit

Public Sub TestMail()

Dim newMail         As Outlook.MailItem
Dim toRange         As Range
Dim ccRange         As Range
Dim fName           As Variant

Set toRange = Sheets("Sheet1").Range("B2:B5")       'Change as required
Set ccRange = Sheets("Sheet1").Range("C2:C5")       'Change as required
With Application.FileDialog(msoFileDialogOpen)

    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "PowerPoint Files", "*.pptx"
    .Filters.Add "PowerPoint 97-2003 Files", "*.ppt"
    .Show
    
    Dim i As Integer
    For i = 1 To .SelectedItems.Count
        fName = .SelectedItems(i)
    Next i
    
End With

If fName <> False Then

    Set newMail = Outlook.CreateItem(olMailItem)
    
    With newMail
    
        Dim cell As Range
    
        For Each cell In toRange
            If cell.Value <> "" Then .To = .To & cell.Value & ";"
        Next cell
        .To = Left(.To, Len(.To) - 1)
        
        For Each cell In ccRange
            If cell.Value <> "" Then .CC = .CC & cell.Value & ";"
        Next cell
        .CC = Left(.CC, Len(.CC) - 1)
    
        .Attachments.Add fName, olByValue
        .Send
        
    End With

End If

End Sub

Hope that helps.

/AJ

 

[anantashesh]

It seems to be running fine but towards the end I get an error on ".Send".

Run-Time Error '-2147467259 (80004005)':
Outlook does not recognize one or more names.

Any idea on why this error is popping up and how I can solve it?

 

[adam087]

Change .Send to .Display and run it again. You should then be able to check all the names are valid.

        .Attachments.Add fName, olByValue
        .Display

/AJ

 

[anantashesh]

Thank You so much for your help and sorry for bugging you, but there is one last error coming up.

The email IDs are not coming out properly in outlook.

I have written the email IDs in this manner:
[TABLE="width: 346"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]To[/TD]
[TD]CC[/TD]
[/TR]
[TR]
[TD]anant@xxxxxx.co.in[/TD]
[TD]sameer@xxxxx.co.in[/TD]
[/TR]
[TR]
[TD]venkatesh.sp@afafdfdaf.co.in[/TD]
[TD]anant@xxxxxx.co.in[/TD]
[/TR]
</tbody>[/TABLE]

In outlook, they are appearing as

To: anant@xxxxxx.co.invenkatesh.sp@afafdfdaf.co.i
CC: sameer@xxxxx.co.inanant@xxxxxx.co.i

Attachments and everything is coming out just like I want it.

Please solve this issue also.

 

[adam087]

Apologies, my code wasn't great. Try replacing the entire With block as so...

    With newMail
    
        Dim cell            As Range
        Dim myRecipient      As Outlook.Recipient
    
        For Each cell In toRange
            If cell.Value <> "" Then .Recipients.Add (cell.Value)
        Next cell
        
        For Each cell In ccRange
            If cell.Value <> "" Then
                Set myRecipient = newMail.Recipients.Add(cell.Value)
                myRecipient.Type = olCC
            End If
        Next cell
    
        .Attachments.Add fName, olByValue
        .Display
        
    End With

/AJ

 

[anantashesh]

Thank You!!!!

It works perfectly and does exactly what I want.

Solved a big issue for me..Thank You Adam!!

 

[adam087]

Cool thanks for the feedback. Apologies for not acknowledging before, I was actually off over Christmas for a change!

/AJ