I'm quite a novice at macros but I've created a macro in Excel that I am want to loop through my spreadsheet and send emails when a specific cell value is null. This code works to send the first email but all the remaining emails show only the first email recipient and subject. It does not execute to send a unique second or any other emails. Please help! I'm exhausted trying everything under the sun.
Below is the code I am using:
Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim objOutlook As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim sTo As String
Dim MailBody As Range
Dim EmailRecipient As String
Dim Signature As String
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("AH5", .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() 120") Then
rngCell.Offset(0, 6).Value = Date
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "According to my records, your " & Range("A5").Value & " contract is due for review " & rngCell.Offset(0, 5).Value & _
". It is important you review this contract ASAP and email me with any changes made. If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the cover sheet along with the new original contract."
EmailSendTo = Sheets("sheet1").Range("AH5").Value
EmailSubject = Sheets("sheet1").Range("A5").Value
Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = EmailSendTo
.CC = "[email protected]"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Display
Send_Value = Mail_Recipient.Offset(i - 1).Value
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next rngCell
Application.ScreenUpdating = True
End Sub
CodePudding user response:
This code works to send the first email but all the remaining emails show only the first email recipient and subject.
Your code creates a new mail items based on the data in the Excel worksheet. But it doesn't send any email automatically. Instead, the code displays a newly created item. To send the mail item you need to call the Send
method instead of Display
as the following code shows:
With OutMail
.To = EmailSendTo
.CC = "[email protected]"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Send
CodePudding user response:
Change rows when creating the mail.
Appears the range is bigger than you think it is. Replacing column AH with column A will probably suffice.
Option Explicit
Sub Macro1()
' Starting in row 5
' Contract ID in column A
' Date in column F
' Zero or positive integer in column G
' Recipient in column AH
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSendTo As String
Dim EmailSubject As String
'Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
'Set Rng = .Range("AH5", .Cells(.Rows.Count, 1).End(xlUp))
'Debug.Print "Rng.Cells.Count: " & Rng.Cells.Count
' To see Rng
'Rng.Select
' Assumes the number of rows in column A is the same as in column AH
Set Rng = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp))
Debug.Print "Rng.Cells.Count: " & Rng.Cells.Count
' To see Rng
'Rng.Select
End With
' Outside of the For loop
Set OutApp = CreateObject("Outlook.Application")
For Each rngCell In Rng
Debug.Print
Debug.Print "rngCell.Row.........: " & rngCell.Row
Debug.Print " rngCell.Offset(0, 6): " & rngCell.Offset(0, 6)
If rngCell.Offset(0, 6) > 0 Then
Debug.Print
Debug.Print " rngCell.Offset(0, 6) > 0 = Do nothing."
Else
Debug.Print
Debug.Print " rngCell.Offset(0, 5): " & rngCell.Offset(0, 5)
Debug.Print " Today 7: " & Evaluate("Today() 7")
Debug.Print " CDbl(rngCell.Offset(0, 5)): " & CDbl(rngCell.Offset(0, 5))
Debug.Print " Today 120: " & Evaluate("Today() 120")
If rngCell.Offset(0, 5) > Evaluate("Today() 7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() 120") Then
Debug.Print " rngCell.Offset(0, 5): " & rngCell.Offset(0, 5) & " = Action"
Set OutMail = OutApp.CreateItem(0)
Dim strbody As String
strbody = "According to my records, your " & Range("A" & rngCell.Row).Value & " contract is due for review " & rngCell.Offset(0, 5).Value & _
". It is important you review this contract ASAP and email me with any changes made. If it is renewed, please fill out the Contract Cover Sheet which can be found in the Everyone folder and send me the cover sheet along with the new original contract."
EmailSendTo = Sheets("sheet1").Range("AH" & rngCell.Row).Value
EmailSubject = Sheets("sheet1").Range("A" & rngCell.Row).Value
With OutMail
.To = EmailSendTo
.CC = "[email protected]"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Display
End With
Set OutMail = Nothing
Else
Debug.Print
Debug.Print " rngCell.Offset(0, 5): " & rngCell.Offset(0, 5) & " = Do nothing."
End If
End If
Next rngCell
Set OutApp = Nothing
Application.ScreenUpdating = True
Debug.Print "Done."
End Sub
Always delete On Error Resume Next
when followed by code for creating mailitems. It should be the correct action 99.99999% of the time.