Email looping a range of data

[Darkcloud617]

I am having an issue with a code looping to the next row. This is meant to go down a range in column A (email addresses) and each one that is not blank it creates an email in outlook. The body of the email is driven by offsetting the cell (or email address) in column A. It should then skip to the next row and create a new email until its reached the end of the email list in column A.

It just duplicates the first match it found. As an example:
a b
1 Header Header
2 Test@Email.com Joe
3 Test2@Email.com Jane

It would create two emails but they would be both be from row 2. If row 4 had data it would create three emails but all three would be from row 1. Etc.

Hopefully that makes sense. Please see below for the troublemaker. Thank you for any assistance or guidance. I am trying to learn.

Sub GenerateEmail()
Application.ScreenUpdating = False

ThisWorkbook.Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim i As Variant

'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String

Dim lstRow As Long

ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id in column 1.
lstRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim rng As Range
Set rng = Range("A2:A" & lstRow)

'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.

For Each i In Range("A2:A100")

MailBody = "Hello," & vbCr & vbCr & "This is the due date: " & i.Offset(0, 1)

For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = "Alert for "
msg = MailBody

On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)

'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = msg
.Subject = subj
.Display

End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends

cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True

Next i

End Sub

 

[Darkcloud617]

I figured out the answer and just wanted to update this for anyone else needing it. The issue was where the loop started. Here is the part modified:

Dim rng As Range
Set rng = Range("A2:A" & lstRow)

'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.

For Each i In rng
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
MailBody = "Hello," & vbCr & vbCr & "Due Date: " & i.Offset(0, 1) 
sendTo = i
subj = "Alert for "
msg = MailBody

With outMail
.To = sendTo
.Body = msg
.Subject = subj
.Display


End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail

Next i 'loop ends