Removing duplicate email addresses from column in mass email

Question

I have a list of people and their email addresses in Excel, linked to the projects they are on. I use it to send project notifications.

I would also like to send a single email to all the people listed on projects, but many are listed multiple times (on different projects).

How do I remove the duplicate email addresses?

Here is the current working code:

Sub SendEmail()

    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim Msg As String

    'Create Outlook object
    Set OutlookApp = New Outlook.Application

    'Loop through the rows
    For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next
    
    Msg = "Dear All," & vbNewLine & vbNewLine
    Subj = "Update"
    
    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
    End With

End Sub

I tried including the .RemoveDuplicates function.

Answer 1

• Using InStr to check if the email is in EmailAddr

    For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" And VBA.InStr(1, EmailAddr, cell.Value, vbTextCompare) = 0 Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next
    If Len(EmailAddr) > 2 Then EmailAddr = Mid(EmailAddr, 2) ' Remove the first ;

Microsoft documentation:

InStr function