Do not ignore duplicate email addresses for VBA - vba

Question

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.

Answer 1

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