I am creating a spreadsheet that will email supervisors 30, 15, and 7 days before the a report is due. Everything is working, except it is sending emails to everyone in Column L and not the designated person in Column L.
Please help. I have copied and pasted the code below.
Public Sub GetDates()
Dim rw As Integer
Dim subj As String
rw = 2
With ActiveSheet
Do Until .Range("A" & rw) = ""
If .Range("M" & rw) = "" Then
If DateAdd("D", 30, Date) = .Range("G" & rw) Then
Call SendEmail(Range("A" & rw), Range("B" & rw), 30, Range("L" & rw), False)
ElseIf DateAdd("D", 15, Date) = .Range("G" & rw) Then
Call SendEmail(Range("A" & rw), Range("B" & rw), 15, Range("L" & rw), False)
ElseIf DateAdd("D", 7, Date) = .Range("G" & rw) Then
Call SendEmail(Range("A" & rw), Range("B" & rw), 7, Range("L" & rw), False)
End If
End If
If Day(Date) = 1 And .Range("G" & rw) < Date And .Range("M" & rw) = "" Then
subj = subj & .Range("A" & rw) & ", " & .Range("B" & rw) & "--" & .Range("C" & rw) & " Report Past Due" & vbCrLf
End If
rw = rw + 1
Loop
If subj <> "" Then
Call SendEmail(subj, "", 0, "supervisor@company.com", True)
Call SendEmail(subj, "", 0, "aothersupervisor@company.com", True)
End If
End With
End Sub
Public Sub SendEmail(lName As String, fName As String, nDays As Integer, sTo As String, LastEmail As Boolean)
Dim iMsg As Object
Dim iConf As Object
Dim cell As Range
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "server"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
For Each cell In ActiveSheet.Columns("L").Cells
If cell.Value Like "?*@?*.?*" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.to = cell.Value
.CC = ""
.BCC = ""
.From = """Report Due"" <donotreply@company.com>"
.Subject = "Report Due"
.HTMLBody = lName & ", " & fName & " <a href='http://www.website.com'>Probation Report</a> / <a href='http://www.website.com'>IDP Report</a> Due in " & nDays & " days"
.Send
End With
Set iMsg = Nothing
End If
Next cell
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
In the SendEmail
subroutine you never use the Column L email parameter, sTo
, and instead routine iterates through every cell in Column L:
For Each cell In ActiveSheet.Columns("L").Cells
...
Next cell
Remove this For
loop and use sTo
:
If sTo Like "?*@?*.?*" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.to = sTo
.CC = ""
.BCC = ""
.From = """Report Due"" <donotreply@company.com>"
.Subject = "Report Due"
.HTMLBody = lName & ", " & fName & " <a href='http://www.website.com'>Probation Report</a> / <a href='http://www.website.com'>IDP Report</a> Due in " & nDays & " days"
.Send
End With
Set iMsg = Nothing
End If
By the way, in your GetDates
subroutine, consider using Select Case over the repeated ElseIf
for readability as you have multiple conditions to manage:
Select Case .Range("G" & rw)
Case DateAdd("D", 30, Date)
Call SendEmail(Range("A" & rw), Range("B" & rw), 30, Range("L" & rw), False)
Case DateAdd("D", 15, Date)
Call SendEmail(Range("A" & rw), Range("B" & rw), 15, Range("L" & rw), False)
Case DateAdd("D", 7, Date)
Call SendEmail(Range("A" & rw), Range("B" & rw), 7, Range("L" & rw), False)
End Select
Alternatively, even shorter:
Select Case .Range("G" & rw) - Date
Case 7, 15, 30
Call SendEmail(Range("A" & rw), Range("B" & rw), _
.Range("G" & rw) - Date, Range("L" & rw), False)
End Select
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.