将Union生成的非连续区域传入Outlook时邮件无数据且报类型不匹配

我们用Excel跟踪学生未交作业：A列是学生姓名，右侧列记录未交情况。未交时老师填自己首字母并添加作业批注；学生提交后，把单元格填充色从xlNone（无填充）改成黄色或灰色。需求是每日自动发送邮件，仅列出填充色为xlNone且含老师首字母的学生及对应信息。

现有VBA代码运行无报错，但邮件正文无数据；注释掉On Error Resume Next后出现「Type Mismatch（类型不匹配）」错误，且工作表相关单元格已被高亮。原代码如下：

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

问题原因分析 #

1. 筛选逻辑完全错误：原代码把xlNone（无填充，未交）和白色、灰色（已提交）的单元格都纳入筛选，和需求完全相反，导致要么结果为空，要么混入已提交记录。
2. 类型不匹配触发点：当没有符合条件的单元格时，rng为Nothing，直接传入RangetoHTML函数会触发类型不匹配错误。
3. 缺失学生姓名关联：原代码只收集作业单元格，邮件里只有老师首字母，无法对应到具体学生。

修复后的代码 #

Sub Mail_Missing_Homework()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim ci As Long
    Dim studentName As Range
    
    Set rng = Nothing
    
    ' 遍历作业记录区域，筛选未交作业（无填充+非空首字母）
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        ' 仅保留无填充（xlNone=-4142）且有非数字内容（老师首字母）的单元格
        If ci = -4142 And Not IsEmpty(cell.Value) And Not IsNumeric(cell.Value) Then
            ' 关联A列对应行的学生姓名
            Set studentName = Sheet1.Cells(cell.Row, "A")
            ' 合并姓名和作业单元格到结果范围
            If rng Is Nothing Then
                Set rng = Union(studentName, cell)
            Else
                Set rng = Union(rng, studentName, cell)
            End If
        End If
    Next cell
    
    ' 无符合条件记录时直接退出，避免错误
    If rng Is Nothing Then
        MsgBox "暂无未交作业的学生记录。", vbInformation
        Exit Sub
    End If
    
    ' 创建Outlook邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "teacher1@school.org, teacher2@school.org"
        .CC = ""
        .BCC = ""
        .Subject = "未交作业学生清单 " & Format(Date, "yyyy-mm-dd")
        .HTMLBody = RangetoHTML(rng)
        .Display ' 测试阶段用Display查看邮件，正式使用替换为.Send
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
    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"

    ' 复制范围并粘贴到临时工作簿
    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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    ' 发布为HTML文件
    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

    ' 读取HTML内容
    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=")

    ' 清理临时文件和工作簿
    TempWB.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

修复说明 #

1. 修正筛选逻辑：仅保留ci = -4142（无填充）且非空、非数字的单元格，精准匹配未交作业的记录。
2. 关联学生姓名：每找到一个未交作业单元格，自动把对应A列的学生姓名加入结果范围，邮件里能清晰看到姓名和对应作业记录。
3. 增加空记录判断：没有未交作业时弹出提示并退出，避免触发类型不匹配错误。
4. 优化邮件主题：添加日期后缀，方便区分每日的邮件。
5. 调试友好设置：默认用.Display显示邮件方便测试，确认无误后可改为.Send自动发送。

内容的提问来源于stack exchange，提问作者middleschoolteacher