How to avoid sending duplicate emails to similar recipient?


Hi, I have set up a reminder date for each recipients. Once due date is trigerred, reminder email will be sent out to them. However, I wish that only one email is being sent out to multiple recipients, and avoid sending duplicate emails to similar recipients. (Note: there are duplicates email address in the list)

Please help! Thank You  =)

Sub datesexcelvba()
Dim OutlookApp As Object, OutlookMail As Object
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim x As Long
lastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastRow
mydate1 = Cells(x, 9).Value
mydate2 = mydate1
Cells(x, 12).Value = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, 13).Value = datetoday2
If mydate2 - datetoday2 = 0 Then
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
OutlookMail.To = Cells(x, 6).Value
With OutlookMail
.CC = ""
.HTMLBody = "Dear All,<p>Please complete above action before the deadline to avoid any unnecessary escalation."
.Importance = olImportanceHigh
.ReadReceiptRequested = True
End With
Cells(x, 10) = "Yes"
Cells(x, 10).Interior.ColorIndex = 3
Cells(x, 10).Font.ColorIndex = 2
Cells(x, 10).Font.Bold = True
Cells(x, 11).Value = mydate2 - datetoday2
End If
Set OutlookApp = Nothing
Set OutlookMail = Nothing
End Sub
Post Edited
CODE Tags: You must add [CODE][/CODE] tags around your code! (click the CODE button to do this when creating a post)



The code below returns a string, separated by semicolons which you can insert directly into the To field of your email. This string is created from a list of email addresses in Sheet1.Columns(6) from which duplicates are removed.

Function UniqueMailList(ByVal MailList As String, _
                        ByVal StartRow As Long, _
                        ByVal Clm As Long) As String
    ' 20 Sep 2017
    Dim Fun() As String                     ' function return value
    Dim WsTmp As Worksheet
    Dim Arr As Variant
    Dim Rng As Range
    Dim Rl As Long                          ' last row
    Dim R As Long
    With Worksheets(MailList)
        Rl = .Cells(.Rows.Count, Clm).End(xlUp).Row
        Arr = .Range(.Cells(StartRow, Clm), .Cells(Rl, Clm)).Value
    End With
    SetApplication False
    Set WsTmp = Worksheets.Add(After:=Worksheets(MailList))
    With WsTmp
        Set Rng = .Cells(1, 1).Resize(UBound(Arr), 1)
        Rng.Value = Arr
        .Range(Rng.Address).RemoveDuplicates Columns:=1, Header:=xlNo
        Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
        Arr = .Range(.Cells(1, 1), .Cells(Rl, 1)).Value
        ReDim Fun(1 To Rl)
        For R = 1 To Rl
            Fun(R) = Arr(R, 1)
        Next R
    End With
    SetApplication True
    UniqueMailList = Join(Fun, ";")
End Function
Private Sub SetApplication(AppMode As Boolean)
    ' 20 Sep 2017
    With Application
        .EnableEvents = AppMode
        .ScreenUpdating = AppMode
        .DisplayAlerts = AppMode
    End With
End Sub

You must call the function giving the location of the addresses, to wit, "Sheet1" and Column 6 as well as the row of the first address (2). The function call then looks like this. (You can paste this line into the VB Editor's Immediate window for testing.)

Debug.Print UniqueMailList("Sheet1", 2, 6)

Integrated into your code it would look like this:-

OutlookMail.To = UniqueMailList("Sheet1", 2, 6)

Of course, you would still be sending multiple emails to all of these recipients due to your x-loop. I presume that the dates are, really, all the same so that you can remove the loop. I hope this helps.


Answer the Question

You must create an account to use the forum. Create an Account or Login