CODEWITHSUNDEEP
vbaexcelduplicates
Yogwhatup
Yogwhatup

Reputation: 362

Do not ignore duplicate email addresses for VBA

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.

 '**********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 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

End Sub

As you can see, there is a need to replace certain information within the e-mail template.

Upvotes: 0

Views: 483

Answers (1)

K.Dᴀᴠɪs
K.Dᴀᴠɪs

Reputation: 10139

For one, do not loop each cell in your column. This is very inefficient. I would recommend you place in an array, then if you must you can loop that.

Also, while declaring workbook/worksheet/range objects is technically optional, it's far from being recommended that you not do this. For starters, if done correctly (as in using meaningful variable names), this can assist in making your code easier to read.

Sub test()

    ' For the love of Pete, declare your objects!!
    Dim ws As Worksheet, rngI As Range
    Set ws = ThisWorkbook.Worksheets("day1")
    Set rngI = ws.UsedRange.Columns("I")

    ' This is your array that contains your emails
    Dim emailArr() As Variant, Email As Variant
    emailArr = rngI.Value

    ' Loop through each email and do what you need to do with it
    For Each Email In emailArr
        Set objOutlook = CreateObject("Outlook.Application")

        'everything you do with this email goes here

    Next

End Sub

Upvotes: 2

Related Questions