Excel Coding to send email


I have a spreadsheet that I want to send email from depending upon the date.  I have it doing everything I want except it's not putting in who the email should go to.  This is the code I have been using.  My email recipient goes in Cell AK6.  Can you tell me how to fix it?  Thank you.


Sub Macro1()

Dim rngCell As Range

Dim rngMyDataSet As Range

Dim Rng As Range

Dim OutApp As Object

Dim OutMail As Object

Dim EmailSubject As String

Dim EmailSendTo As String

Dim MailBody As String

Dim EmailRecipient As String

Dim Signature As String

Application.ScreenUpdating = False

With ActiveSheet

If .FilterMode Then .ShowAllData

Set Rng = .Range("AK6", .Cells(.Rows.Count, 1).End(xlUp))

End With

For Each rngCell In Rng

If rngCell.Offset(0, 6) > 0 Then


ElseIf rngCell.Offset(0, 5) > Evaluate("Today() +7") And _

rngCell.Offset(0, 5).Value <= Evaluate("Today() +30") Then

rngCell.Offset(0, 6).Value = Date


Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)


strbody = "According to my records, your contract " & Range("A1").Value & " is due for review on " & rngCell.Offset(0, 5).Value & vbNewLine & _

"Please review this contract prior to the pertinent date and email me with any changes you make to this contract.  If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the new original contract."

EmailSendTo = rngCell.Offset(0, 0).Value

EmailSubject = Sheets("sheet1").Range("A6").Value

EmailRecipient = rngCell.Offset(0, 1).Value

Signature = "C:\Documents and Settings\" & Environ("rmm") & _

"\Application Data\Microsoft\Signatures\rm.htm"

On Error Resume Next

With OutMail

.to = EmailSendTo

.CC = "email address removed for privacy reasons"

.BCC = ""

.Subject = EmailSubject

.Body = strbody


End With

On Error GoTo 0

Set OutMail = Nothing

Set OutApp = Nothing


End If


Next rngCell

Application.ScreenUpdating = True

End Sub

2 Replies


The line


Set Rng = .Range("AK6", .Cells(.Rows.Count, 1).End(xlUp))


sets Rng to a range in columns A, B, C, ..., AK. For example, if the last filled cell in column A is A40, Rng is the range A6:AK40

You loop through ALL cells in that range. Is that really what you intended?

@Hans Vogelaar 


Right now I'm only using one line of data to set this sheet up to send email.  I will actually have about a dozen different emails in there when I get it to working right.  Right now, it creates the email and puts the message in, but it is not putting in the recipient's email in the TO line.