Macro that emails a list of tasks due today

[Garden Utopia Productions]

I'm starting to learn VBA. I've got a list of tasks that are due on various days. They are divided and organized by different departments. What I need to do is scan through the whole range of dates and then automatically send an email with the tasks that are due today.

I found some VBA code that essentially does this, except it creates an email for each task that's due today. I want to be able to generate one email with the list of tasks in that email. I know I need to move the call to open Outlook outside the For loop, but I don't know how to do it correctly.

Here's the code below:

Public Sub CheckAndSendMail()
    Dim xRgDate As Range
    Dim xRgDepartment As Range
    Dim xRgTask As Range
    
    Dim xOutApp As Object
    Dim xMailItem As Object
    
    Dim xLastRow As Long
    Dim i As Long
    
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    
    Dim xIsDateANumber As Boolean
        
    On Error Resume Next
    
    Set xRgDate = Application.InputBox("Please select the due date column:", "Task Checker", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgDepartment = Application.InputBox("Select the Department column:", "Task Checker", , , , , , 8)
    If xRgDepartment Is Nothing Then Exit Sub
    Set xRgTask = Application.InputBox("Select the Tasks Number column:", "Task Checker", , , , , , 8)
    If xRgTask Is Nothing Then Exit Sub
    
    xLastRow = xRgDate.Rows.Count
    
    Set xRgDate = xRgDate(1)
    Set xRgDepartment = xRgDepartment (1)
    Set xRgTask = xRgTask(1)
    Set xOutApp = CreateObject("Outlook.Application")
    
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then                    'Checks for blank cells
          If CDate(xRgDateVal) = Date Then                'Checks if date = today's date
            If xIsDateANumber <> IsDate(xRgDateVal) Then    'Checks if date is a valid date
              xMailSubject = "The following Tasks are due today: " & xRgDateVal
              vbCrLf = "

"
              xMailBody = "******>"
              xMailBody = xMailBody & "Attention! " & vbCrLf
              xMailBody = xMailBody & xRgDepartment.Offset(i - 1).Value & " " & xRgTask.Offset(i - 1).Value & " is due today!" & vbCrLf
              xMailBody = xMailBody & ""
              Set xMailItem = xOutApp.CreateItem(0)
              With xMailItem
                .Subject = xMailSubject
                .To = "1st_email@domain.com"
                .Cc = "2nd_email@domain.com"
                .HTMLBody = xMailBody
                .Display
                '.Send
              End With
              Set xMailItem = Nothing
            End If      'End IsDate IF
          End If        'End today's date IF
        End If          'End blank cell IF
    Next
    Set xOutApp = Nothing
End Sub

Thanks in advance!

 

[John_w]

Untested, but try something like this:

Public Sub CheckAndSendMail()
    Dim xRgDate As Range
    Dim xRgDepartment As Range
    Dim xRgTask As Range
    
    Dim xOutApp As Object
    Dim xMailItem As Object
    
    Dim xLastRow As Long
    Dim i As Long
    
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    
    Dim xIsDateANumber As Boolean
        
    On Error Resume Next
    
    Set xRgDate = Application.InputBox("Please select the due date column:", "Task Checker", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgDepartment = Application.InputBox("Select the Department column:", "Task Checker", , , , , , 8)
    If xRgDepartment Is Nothing Then Exit Sub
    Set xRgTask = Application.InputBox("Select the Tasks Number column:", "Task Checker", , , , , , 8)
    If xRgTask Is Nothing Then Exit Sub
    
    xLastRow = xRgDate.Rows.Count
    
    Set xRgDate = xRgDate(1)
    Set xRgDepartment = xRgDepartment (1)
    Set xRgTask = xRgTask(1)
    
    xMailSubject = ""
    xMailBody = "Attention! " & vbCrLf
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then                    'Checks for blank cells
          If CDate(xRgDateVal) = Date Then                'Checks if date = today's date
            If xIsDateANumber <> IsDate(xRgDateVal) Then    'Checks if date is a valid date
              xMailSubject = "The following Tasks are due today: " & xRgDateVal
              xMailBody = xMailBody & xRgDepartment.Offset(i - 1).Value & " " & xRgTask.Offset(i - 1).Value & " is due today!" & vbCrLf
            End If      'End IsDate IF
          End If        'End today's date IF
        End If          'End blank cell IF
    Next
    
    xMailBody = xMailBody & vbCrLf & "More email body text here."

    if xMailSubject <> "" Then
          Set xOutApp = CreateObject("Outlook.Application")
          Set xMailItem = xOutApp.CreateItem(0)
          With xMailItem
            .Subject = xMailSubject
            .To = "1st_email@domain.com"
            .Cc = "2nd_email@domain.com"
            .HTMLBody = xMailBody
            .Display
            '.Send
          End With
    End IF

End Sub

Note that your code is slightly screwed up because this forum can't handle HTML tags within code. A workaround, just for posting purposes, is to add a space after each "<" character.

 

[Garden Utopia Productions]

Untested, but try something like this:


Note that your code is slightly screwed up because this forum can't handle HTML tags within code. A workaround, just for posting purposes, is to add a space after each "<" character.

Thanks for the HTML tag tip and for the code! I'll give it a go and let you know how it works.

 

[Garden Utopia Productions]

Untested, but try something like this:
...

Hey John_w, thanks again for the code. I had to edit a couple things, but it works perfectly! Cheers!

 

[Garden Utopia Productions]

Now that the code can print the list of tasks due in one email, I want to add an if outside the for loop that prints "No tasks due today" if nothing is actually due today.

I added an else inside the for loop, but "No tasks due today" gets printed as many times are there are rows in the range checked. I wouldn't mind cleaning it up if there weren't the potential for 1000+ rows.
Here's my code with the else commented out.

Public Sub CheckAndSendMail()
    Dim xRgDate As Range
    Dim xRgDepartment As Range
    Dim xRgTask As Range
    
    Dim xOutApp As Object
    Dim xMailItem As Object
    
    Dim xLastRow As Long
    Dim i As Long
    
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    
    Dim xIsDateANumber As Boolean
        
    On Error Resume Next
    
    Set xRgDate = Application.InputBox("Please select the due date column:", "Task Checker", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgDepartment = Application.InputBox("Select the Department column:", "Task Checker", , , , , , 8)
    If xRgDepartment Is Nothing Then Exit Sub
    Set xRgTask = Application.InputBox("Select the Tasks Number column:", "Task Checker", , , , , , 8)
    If xRgTask Is Nothing Then Exit Sub
    
    xLastRow = xRgDate.Rows.Count
    
    Set xRgDate = xRgDate(1)
    Set xRgDepartment = xRgDepartment(1)
    Set xRgTask = xRgTask(1)
    
    vbCrLf = "<br>"
    
    xMailSubject = ""
    xMailBody = "< HTML >< BODY >"
    xMailBody = "Attention! " & vbCrLf
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then                    'Checks for blank cells
          If CDate(xRgDateVal) = Date Then                'Checks if date = today's date
            
            If xIsDateANumber <> IsDate(xRgDateVal) Then    'Checks if date is a valid date
              xMailSubject = "The following Tasks are due today: " & xRgDateVal
              xMailBody = xMailBody & xRgDepartment.Offset(i - 1).Value & " " & xRgTask.Offset(i - 1).Value & " " & vbCrLf
            End If      'End IsDate IF
            
'          Else        'If no Deliverables are due today
'              xMailSubject = "No Tasks are due today: " & xRgDateVal
'              xMailBody = xMailBody & "No Tasks are due today. " & vbCrLf
          End If        'End today's date IF
        End If          'End blank cell IF
    Next
    
'  I was hoping I could check to see if xMailBody any value and if not then print the no tasks due, but this doesn't work. 
'    If xMailBody = Empty Then
'       xMailSubject = "No Tasks are due today: " & xRgDateVal
'       xMailBody = xMailBody & "No Tasks are due today. " & vbCrLf
'    End If
    
    xMailBody = xMailBody & vbCrLf & " "
    xMailBody = xMailBody & "< /BODY >< /HTML >"
    If xMailSubject <> "" Then
          Set xOutApp = CreateObject("Outlook.Application")
          Set xMailItem = xOutApp.CreateItem(0)
          With xMailItem
            .Subject = xMailSubject
            .To = "1st_email@domain.com"
            .Cc = "2nd_email@domain.com"
            .HTMLBody = xMailBody
            .Display
            '.Send
          End With
    End If


End Sub

 

[Garden Utopia Productions]

Never mind! I added another boolean variable that gets used to check whether tasks were due today or not.