Do not ignore duplicate email addresses for VBA

[wilsonjr5]

In this code, the script will exclude duplicate email addresses. I want the opposite, as I want to include duplicate email addresses and send them each a separate e-mail. I do not know what part of the code to modify to get the intended result.

[COLOR=#303336][FONT=inherit]'--- Begin looping through all the e-mail addresses in column A until[/FONT][/COLOR]
<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">[COLOR=#303336][FONT=inherit]'    a blank cell is hit.
While ActiveWorkbook.Sheets("day1").Range("I" & X).Text <> ""

    '--- These variables will be used to search for duplicates.
    CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X).Text
    TempCustomerAddress = CustomerAddress
       
    '--- Increment X until a different e-mail address is found.
    While TempCustomerAddress = CustomerAddress
        X = X + 1
        CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X).Text
    Wend
    
    '--- Add the e-mail address to a global variable.
    CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X - 1).Text
    '--- Run the subroutine to send the message.

    '--- This is required to prevent a name which does not resolve to
    '    an e-mail address from hanging the app.
    On Error Resume Next
    
    ' Create the Outlook session. [/FONT][/COLOR]</code>[COLOR=#303336][FONT=inherit]    Set objOutlook = CreateObject("Outlook.Application") [/FONT][/COLOR]

Thank you for your help!!!

 

[wilsonjr5]

Here is the complete code:

[COLOR=#303336][FONT=inherit] '**********You MUST DO THIS FIRST**********[/FONT][/COLOR]<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">[COLOR=#303336][FONT=inherit]'On the Tools menu, click References.
'In the Available References list, click to select the 'Microsoft Outlook 9.0 Object Library check box. Click OK.
'--- Set up the Outlook objects.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim body As String
Dim T As Integer
Dim Y As Integer
    
'--- Declare our global variables to be used in each subroutine.
Dim CustomerAddress As String
Dim CustomerMessage As String

Sub MailItNow()
'--- Declare our variables.
Dim X As Integer
Dim TempCustomerAddress As String
ActiveWorkbook.Sheets("day1").Select
Range("A1").Select

'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False

'--- Sets which row to start searching for e-mail addresses and names.
X = 2

'--- Begin looping through all the e-mail addresses in column A until
'    a blank cell is hit.
While ActiveWorkbook.Sheets("day1").Range("I" & X).Text <> ""

      
    '--- Increment X until a different e-mail address is found.
    While TempCustomerAddress = CustomerAddress
        X = X + 1
        CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X).Text
    Wend
    
    '--- Add the e-mail address to a global variable.
    CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X - 1).Text
    '--- Run the subroutine to send the message.

    '--- This is required to prevent a name which does not resolve to
    '    an e-mail address from hanging the app.
    On Error Resume Next
    
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItemFromTemplate("C:\Users\me\new.oft")
      
    f = ActiveWorkbook.Sheets("day1").Range("B" & X - 1)
    g = ActiveWorkbook.Sheets("day1").Range("C" & X - 1)
    h = ActiveWorkbook.Sheets("day1").Range("E" & X - 1)
    j = ActiveWorkbook.Sheets("day1").Range("D" & X - 1)
    k = ActiveWorkbook.Sheets("day1").Range("F" & X - 1)
    l = ActiveWorkbook.Sheets("day1").Range("G" & X - 1)
    m = ActiveWorkbook.Sheets("day1").Range("H" & X - 1)
    n = ActiveWorkbook.Sheets("day1").Range("I" & X - 1)
    o = ActiveWorkbook.Sheets("day1").Range("J" & X - 1)
    
    With objOutlookMsg
        ' Add the To recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add(CustomerAddress)
        objOutlookRecip.Type = olTo
        .HTMLBody = Replace(.HTMLBody, "Field1", f)
        .HTMLBody = Replace(.HTMLBody, "Field2", g)
        .HTMLBody = Replace(.HTMLBody, "Field3", h)
        .HTMLBody = Replace(.HTMLBody, "Field4", j)
        .HTMLBody = Replace(.HTMLBody, "Field5", k)
        .HTMLBody = Replace(.HTMLBody, "Field6", l)
        .HTMLBody = Replace(.HTMLBody, "Field7", m)
        .HTMLBody = Replace(.HTMLBody, "Field8", n)
        .HTMLBody = Replace(.HTMLBody, "Field9", o)
        .Importance = olImportanceHigh  'High importance
    
       ' Add attachments to the message.
        If Not IsMissing(AttachmentPath) Then
            Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        End If
        
        ' Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
            If Not objOutlookRecip.Resolve Then
            Exit Sub
        End If
        Next
        .Send '--- Send the message.
    
    End With
    
    '--- Remove the message and Outlook application from memory.
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing

Wend
 [/FONT][/COLOR]</code>[COLOR=#303336][FONT=inherit]End Sub[/FONT][/COLOR]