Send Automatic Email for loop - vba

Question

I have a code:
Sub sendEmail()
Dim OutlookApp As Object
Dim OutlookItem As Object
Dim i As Integer
Dim Address As String
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookItem = OutlookApp.CreateItem(0)
With OutlookItem
For i = 4 To 15
If Cells(i, 18) <= Cells(i, 6) Then
Address = Cells(i, 14).Value
Set OutlookApp = CreateObject("Outlook.application")
Set OutlookItem = OutlookApp.CreateItem(0)
.To = Address
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & Cells(i, 4) & "is due on " & Cells(i, 9)
.Send
Set OutlookItem = Nothing
Set OutlookApp = Nothing
'Application.Wait (Now + #12:00:08 AM#)
ElseIf Cells(i, 18) > Cells(i, 15) Then
Exit Sub
ElseIf Cells(i, 18) = "" And Cells(i, 15) = "" Then
Exit Sub
End If
Next i
End With
End Sub
It does send only first email then it prompts me with run-time error saying :
The item has been moved or deleted
And debugger highlights the " .To = Address" line.
When I use .Display instead of send it works.
Any ideas?

Answer 1

Re-creating the Outlook application object in every loop iteration does not make sense. It's equivalent to killing Outlook and re-starting it for every mail you send. Let's not do that.
First, set a reference to the "Microsoft Outlook 15.0 Object Library" in your Excel VBA project (or whatever version you happen to have installed).
Now you can create an Outlook object directly with New and it also enables the autocompletion and all the Outlook-specific constants, like olMailItem.
Now your code can be condensed to something like this:
Sub sendEmail()
Dim OutlookApp As New Outlook.Application
Dim r As Range
For Each r In ActiveSheet.Range("4:15").Rows
If r.Cells(18) <= r.Cells(6) And r.Cells(18) > "" And r.Cells(15) > "" Then
With OutlookApp.CreateItem(olMailItem)
.To = r.Cells(14)
.Subject = "Calibration Due Soon !!!"
.Body = "Reminder: Calibration of " & r.Cells(4) & " is due on " & r.Cells(9)
.Send
End With
End If
Next r
OutlookApp.Quit
Set OutlookApp = Nothing
End Sub