Email issue on duplicate email address

[Madz1101]

Below is code i am using to send email. It is working fine as long as the column C doesn't have any duplicate email in it. Outlook doesn't open for duplicate email.

I am not very good at VBA and i have written this code with alot of help and searching from internet.

Can anyone please see why on duplicate email outlook is not opening?

thanks

lastrow = Range("C" & Rows.Count).End(xlUp).Row
For Each cell In Range("C8:C" & lastrow)

If WorksheetFunction.CountIf(Range("C8:C" & cell.Row), cell) = 1 Then

If Cells(cell.Row, 16) = "Yes" Then

Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Some text here"
On Error Resume Next

With xOutMail
.To = Cells(cell.Row, 3)
.CC = Cells(cell.Row, 6) & "; " & Cells(cell.Row, 11)
.BCC = ""
.Subject = "Subject"
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing

Cells(cell.Row, 16).Value = "No"

 

[Deepak]

Hi,

Below line is checking that email will not send to any email duplicate email in said range on each loop.

If WorksheetFunction.CountIf(Range("C8:C" & cell.Row), cell) = 1 Then

What you want in case of multiple existence...

• Send email to all if duplicate - then just remove that line and end if .
• Or something else then let us know with complete code as u might not able to alter the suggestion provided here due to novoice.

 

[Madz1101]

Thanks Deepak. I removed the line you mentioned and email is being sent as desired.

Thank you so much