VBA not including duplicate e-mail addresses

wilsonjr5

New Member
Joined
Feb 13, 2018
Messages
6
This is driving me crazy and I really need someone to give me a lifeline here :)
I have a VBA code for Excel that populates information in outlook e-mails based on certain cells.

The problem is the code works flawlessly, unless it runs into a duplicate e-mail! It will only send out one e-mail (usually the first one). What can I modify to ensure it sends an e-mail to every cell that has one, even if it is a duplicate?


Code:
'**********You MUST DO THIS FIRST**********'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 dayonemail()
'--- Declare our variables.
Dim X As Integer
Dim AA As Long, i As Long
Sheets(4).Select
Range("A1").Select


AA = Range("I" & Rows.Count).End(xlUp).Row


If AA >= 3 Then


'--- 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 <> ""
'---------------------------------------------------------------------------------------------------------
    '--- These variables will be used to search for duplicates.
'    CustomerAddress = ActiveWorkbook.Sheets("day1").Range("J" & 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.
    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("E" & X - 1)
    H = ActiveWorkbook.Sheets("day1").Range("Z" & X - 1)
    J = ActiveWorkbook.Sheets("day1").Range("Z" & 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
            Resume Next
        End If
        Next
        .Send '--- Send the message.
    
    End With
    
    '--- Remove the message and Outlook application from memory.
    Set objOutlookMsg = Nothing
    Set objOutlook = Nothing


Wend
Else
End If
End Sub
 
Last edited:

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Try commenting out these lines by putting an apostrophe at the beginning of them:

Code:
    '--- 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
 
Upvote 0
Sorry! a single quote, not apostrophe.
 
Upvote 0

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top