Email Macro pulling from Excel recipient list

[willow1985]

Hello,

I have the below Macro that takes data, puts it in an email and then pulls a recipient list from that same data, however the problem I am having is if there is a duplicate email address in the list it sends a duplicate email to that recipient. Is there a way to modify this so it sends unique values only? (Only emails a recipient one time?)

I got help with the below code from someone on this board so I do not know how to modify it or even a code that would grab only the unique values from column M.

Thank you to anyone who can help!!

Sub sendmail2()
'
' sendmail2 Macro
'
Application.ScreenUpdating = False
Worksheets("Automatic Emails").Visible = True

  Dim OutlookApp As Object, MItem As Object, cad As String
  Dim i As Long, sh As Worksheet, rng As Range, lr As Long
 
  Set sh = Sheets("Automatic Emails")
  lr = sh.Range("AD" & Rows.Count).End(xlUp).Row
 
  For i = 2 To lr
    cad = cad & sh.Range("AD" & i).Value & "; "
  Next
  Set OutlookApp = CreateObject("Outlook.Application")
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
    .To = sh.Range("AD1").Value & ";" & sh.Range("AD2").Value
    .Subject = "Audit Schedule UPDATE REQUIRED"
    .htmlBody = "<br>AUDIT LIST UPDATE REQUIRED THE DIVISION FOR UPCOMING YEAR<br>" & _
      "<br>[This is an Automated Message - Do not reply]<br>" & _
      "Audit Scheduler"
    .Display
    .Send
  End With
 
Application.ScreenUpdating = True
Worksheets("Automatic Emails").Visible = False
 
End Sub

Cadorath Internal Audit Schedule.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Scheduled Month:	Element:	Severity Level:	Auditor:	Date Completed:	Filed Y/N	Previous Audit Date	Finding Raised Y/N:	CAPA #:	Flag Date	Due Date	Link to Audit form	Email List
2	April	Process Audit 2					2020-06-26			2021-05-26	2021-06-26	\\DAVINCI-1\CADODATA\QA_MANUALS\Audit%20Forms\ISO\Uniflyte%20Process%20Audit%202%20%20Product%20Realization.doc
3	April	Coatings Process Audit 2		Ed			2020-06-18			2021-05-18	2021-06-18	\\DAVINCI-1\CADODATA\QA_MANUALS\Audit%20Forms\ISO\Coatings%20Process%20Audit%202%20Repairs%20Processes%20Product%20Realization.doc	Ed@noemail.com
4	August	Coatings Process Audit 6	N/A	Shane			2019-10-30			2020-09-30	2020-10-30	\\DAVINCI-1\CADODATA\QA_MANUALS\Audit%20Forms\ISO\Uniflyte%20Process%20Audit%206%20Quality%20System%20.doc	shane@noemail.com
5	May	CADI PCSM Audit		Ed			2019-07-26			2020-06-26	2020-07-26	\\DAVINCI-1\CADODATA\QA_MANUALS\Audit%20Forms\ISO\PCSM%20Audit%20Checklist%20Rev%203.doc	Ed@noemail.com
Automatic Emails

Cell Formulas
Range	Formula
L2:L5	L2	=INDEX(W:W,MATCH(B2,V:V,FALSE))
M2:M5	M2	=IFERROR(INDEX(O:O,MATCH(D2,N:N,FALSE)),"")

Cells with Data Validation
Cell	Allow	Criteria
F1	List	='Audit List'!$F$1:$F$2

 

[KOKOSEK]

Hmm, I understand you question but my question is: ed@noemail.com can gets 2 emails with 2 different messages.
1 about Coatings Process Audit 2
2 about CADI PCSM Audit
How do you want to decide which have to be sent and which not, if you said that you want to avoid duplicate recipients?
There is no other criteria? Like scheduled month in col. A?

 

[willow1985]

Hmm, I understand you question but my question is: ed@noemail.com can gets 2 emails with 2 different messages.
1 about Coatings Process Audit 2
2 about CADI PCSM Audit
How do you want to decide which have to be sent and which not, if you said that you want to avoid duplicate recipients?
There is no other criteria? Like scheduled month in col. A?

the entire chart goes to all recipients but I realized I posted the wrong VBA code and I apologize (working from home with little ones is not easy).
Anyway here is the correct VBA that matches the above spreadsheet posted. I want to only include unique email addresses in column M for the To (aka cad) line:

Sub sendmail()
  Dim OutlookApp As Object, MItem As Object, cad As String
  Dim i As Long, sh As Worksheet, rng As Range, lr As Long
 
  Set sh = Sheets("Automatic Emails")
  lr = sh.Range("B" & Rows.Count).End(xlUp).Row
  Set rng = sh.Range("B1:L" & lr)
  For i = 2 To lr
'the below line
    cad = cad & sh.Range("M" & i).Value & "; "
  Next
  Set OutlookApp = CreateObject("Outlook.Application")
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
    .To = cad
    .Subject = sh.Range("Q1").Value
    .htmlBody = sh.Range("Q2").Value & RangetoHTML(rng) & _
      "<br>[This is an Automated Message - Do not reply]<br>" & _
      "Audit Scheduler"
    .Display
    .Send
  End With
End Sub

 

[Sequoyah]

Hello,
how about

Option Explicit

Sub sendmail3()
      
    Dim X
    Dim objDict As Object
    Dim lngRow As Long
    Dim OutlookApp As Object, MItem As Object, cad As String
    Dim i As Long, sh As Worksheet, rng As Range, lr As Long
    
     With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set sh = Sheets("Automatic Emails")
    lr = sh.Range("B" & Rows.Count).End(xlUp).Row
    Set rng = sh.Range("B1:L" & lr)
    
    Set objDict = CreateObject("Scripting.Dictionary")
    X = Application.Transpose(Range([M2], Cells(Rows.Count, "M").End(xlUp)))
    
    For lngRow = 1 To UBound(X, 1)
        objDict(X(lngRow)) = 1
    Next
    
    For i = 1 To objDict.Count
        
        cad = X(i)
        
        Set OutlookApp = CreateObject("Outlook.Application")
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = cad
            .Subject = sh.Range("Q1").Value
            .htmlBody = sh.Range("Q2").Value & RangetoHTML(rng) & _
                        "<br>[This Is an Automated Message - Do Not reply]<br>" & _
                        "Audit Scheduler"
            .Display
            ' .Send
        End With
    Next
    
    Set OutlookApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    'Range("N1:N" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                  "align=left x:publishsource=")
    
    'Close TempWB
    TempWB.Close savechanges:=False
    
    'Delete the htm file we used in this function
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function