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
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next rngCell
Application.ScreenUpdating = True
End Sub
