Hi All,
I am using the following Macro to check due dates and create and send emails based on due dates. I am in need of one last piece to finalize this, and that would be:
if range is "complete" do next row. That meaning if the task is complete, it would skip that row and go to the next task. Any help is greatly appreciated.
I am using the following Macro to check due dates and create and send emails based on due dates. I am in need of one last piece to finalize this, and that would be:
if range is "complete" do next row. That meaning if the task is complete, it would skip that row and go to the next task. Any help is greatly appreciated.
Code:
Private Sub Workbook_Open()
Dim password
If Application.UserControl Then
password = Application.InputBox("Enter Password", "Password Protected Macro")
Else
password = "rbi"
End If
Select Case password
Case Is = False
'do nothing
Case Is = "rbi"
Dim Complete As Range
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgCopy As Range
Dim xRgText As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xRgCopyVal As String
Dim xMailSubject As String
Dim i As Long
On Error Resume Next
Set xRgDate = Range("D11:D10000")
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Range("G11:G10000")
If xRgSend Is Nothing Then Exit Sub
Set xRgCopy = Range("H11:H10000")
If xRgCopy Is Nothing Then Exit Sub
Set xRgText = Range("C11:C10000")
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgCopy = xRgCopy(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date = 60 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = ("You have an Action Item due in 60 Days!")
vbCrLf = "
"
xMailBody = "******>"
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
xMailBody = xMailBody & "The following action items is coming due: " & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
.Display
.Send
End With
ElseIf CDate(xRgDateVal) - Date = 30 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = ("You have an Action Item due in 30 Days!")
vbCrLf = "
"
xMailBody = "******>"
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
xMailBody = xMailBody & "The following action item is coming due: " & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
.Display
.Send
End With
ElseIf CDate(xRgDateVal) - Date <= 0 And CDate(xRgDateVal) - Date < 0 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xRgCopyVal = xRgCopy.Offset(i - 1).Value
xMailSubject = ("You have an Action Item Overdue!")
vbCrLf = "
"
xMailBody = "******>"
xMailBody = xMailBody & "Dear " & xRgSendVal & " & " & xRgCopyVal & vbCrLf
xMailBody = xMailBody & "The following action item is overdue : " & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.Cc = xRgCopyVal
.HTMLBody = xMailBody
.Display
.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
Case Else
MsgBox "Incorrect Password"
End Select
End Sub
Last edited by a moderator:
