Passing a Non-Contiguous Range from a Union into Outlook - excel

Question

A group of teachers (I am one) is using a spreadsheet to track missing assignments of students. The students' names are in column A, and missing assignments expand in columns to the right.
When an assignment is missing, the teacher puts their initial in the cell and right-clicks to add a comment about the assignment.
When the student submits the assignment, the teacher changes the cell's fill from nothing (xlNone) to yellow or grey.
We'd like Excel to send us a daily email that lists only the students with missing assignments in cells filled with xlNone along with the initial of the teacher or teachers.
This code does not error. The email object is constructed, but there is no data in the body of the email.
Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
On Error Resume Next
Dim cell As Range
Dim ci As Long
Set rng = Nothing
For Each cell In Sheet1.Range("C4:Z100").Cells
ci = cell.Interior.ColorIndex
If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.Value) Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Application.Union(rng, cell)
End If
End If
Next cell
If Not rng Is Nothing Then rng.Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "teacher1#school.org, teacher2#school.org"
.CC = ""
.BCC = ""
.Subject = "This is the list of students with missing work"
.HTMLBody = RangetoHTML(rng)
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Thanks to Ron de Bruin's page
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I commented On Error Resume Next out as suggested and get an error
'Type Mismatch'
Looking at the sheet, the various cells are highlighted.

Answer 1

Hello middleschoolteacher,
UPDATED ANSWER
Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin
' Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
' On Error Resume Next
Dim cell As Range
Dim ci As Long
' Set rng = Nothing
Dim str As String
str = Empty
For Each cell In Sheet1.Range("C4:Z100").Cells
ci = cell.Interior.ColorIndex
If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
'****************************************************************************
' If rng Is Nothing Then
' Set rng = cell
' Else
' Set rng = Application.Union(rng, cell)
' End If
str = str & CStr(cell.value) & " "
'****************************************************************************
End If
Next cell
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' On Error Resume Next
With OutMail
.To = "teacher1#school.org, teacher2#school.org"
.CC = ""
.BCC = ""
.Subject = "This is the list of students with missing work"
'****************************************************************************
Dim wdDoc As Object
Dim olinsp As Object
Set wdDoc = CreateObject("Word.Document")
Set olinsp = .GetInspector
Set wdDoc = olinsp.WordEditor
If Not IsEmpty(str) Then
wdDoc.Range.InsertBefore str
.Display
.Send
Else
MsgBox prompt:="No cells meet the criteria"
Exit Sub
End If
'****************************************************************************
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set wdDoc = Nothing
Set olinsp = Nothing
End Sub
So, I'm not sure this gives you the intended result, however after testing with a test worksheet I successfully displayed the email with all the relevant cell values separated by a space (you can choose whatever you want to separate the values, you just need to replace the " " on the line containing str = str & CStr(cell.value) & " " .
I changed where the .Send method is on the code so that no email is sent if there are no relevant cells.
I fail to understand how are you going to know which student hasn't yet submitted the assignment as the relevant cells contain only the initial of the teacher? Or am I getting this wrong?
If you need to include the student's name also for each cell value then the code can be easily modified to do that, however I'm not sure that I fully understand what is the desired output is here.
Anyways let me know how it goes.
ADDITION
You can output a single line like this: studentA_J studentB_F studentC_W , J F and W being the initials of the teachers. In order to achieve that you need only the the line containing str = str & CStr(cell.value) & " " and change it to str = str & Sheet1.Cells(cell.row,j) & "_" & CStr(cell.value) & " " , where j needs to be the index of the column where the student's name is.
If I remember correctly you can even write it using the letter of the column, for example if the students names are in column A then you can also replace the above line of code also by str = str & Sheet1.Cells(cell.row,"A") & "_" & CStr(cell.value) & " "
UPGRADED CODE
Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, studentCell As Range
Dim ci As Long
Dim str As String
str = Empty
With Application
.calculation = xlCalculationManual
.DisplayStatusBar = False
.enableEvents = False
.screenUpdating = False
.Interactive = False
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
For Each cell In Sheet1.Range("C4:Z100").Cells
ci = cell.Interior.ColorIndex
If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
'****************************************************************************
Set studentCell = Sheet1.Cells(cell.Row, "A")
With cell
If Not .CommentThreaded Is Nothing Then
str = str & studentCell.value & "_" & CStr(.value) & "_" & .CommentThreaded.Text & vbCrLf
Else
str = str & studentCell.value & "_" & CStr(.value) & vbCrLf
End If
End With
'****************************************************************************
End If
Next cell
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "teacher1#school.org, teacher2#school.org"
.CC = ""
.BCC = ""
.Subject = "This is the list of students with missing work"
'****************************************************************************
Dim wdDoc As Object
Dim olinsp As Object
Set wdDoc = CreateObject("Word.Document")
Set olinsp = .GetInspector
Set wdDoc = olinsp.WordEditor
If Not IsEmpty(str) Then
wdDoc.Range.InsertBefore str
Else
MsgBox prompt:="No cells meet the criteria"
GoTo SafeExit
End If
'****************************************************************************
.Display
.Send
End With
SafeExit:
With Application
.calculation = xlCalculationAutomatic
.DisplayStatusBar = False
.enableEvents = False
.screenUpdating = False
.Interactive = False
.DisplayAlerts = False
.AskToUpdateLinks = False
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set wdDoc = Nothing
Set olinsp = Nothing
End Sub
If you use this upgraded code then it will run much faster.