Excel VBA自动发邮件：无证书人员邮件触发失败问题排查

核心问题分析 #

1. 空单元格计数范围错误
   原代码中emptyCount = 0写在For Each RName In RNames循环外部，导致该变量累计的是所有人员列的空单元格总数，而非单个人员对应的53个设备单元格的空值数量。即使某个人的列全空，emptyCount也会因为之前人员的统计结果而偏离53，无法触发目标条件。

2. 隐性逻辑遗漏
   原代码中无证书提醒的邮件块缺少.Display或.Send语句，即便条件触发，邮件也仅在后台创建，不会显示或发送。

修复步骤 #

1. 将emptyCount = 0移至For Each RName In RNames循环内部、If isEmpty(RName) = False Then之后，确保每次处理单个人员时从零开始统计其列内空单元格。
2. 为避免单元格含空白文本（非真正空值）导致计数错误，将isEmpty(R)替换为Trim(R.Value) = ""，覆盖空格占位的情况。
3. 在无证书提醒的邮件块中添加.Display（或.Send）语句，确保邮件正常触发。

修改后的完整代码 #

Sub AutoMailerFinalSheet3()

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim RList As Range
Set RList = Range("C5", "BZ57")
Dim R As Range
Dim emptyCount As Integer
Dim Password As Variant
Dim sBodyOne As String
Dim sBodyTwo As String
Dim sWarnOne As String
Dim sWarnTwo As String
Dim RNames As Range, RName As Range
Set RNames = Range("C2", "P2")
Dim sOverdue As String

Password = Application.InputBox("Enter Password", "Password Protected")

Select Case Password
    Case Is = False
        '
    Case Is = "PPQE"
        For Each RName In RNames
            emptyCount = 0 ' 移至此处，每次处理单个人员时重置计数
            If IsEmpty(RName) = False Then
        
            sOverdue = "due"
  
            For Each R In Intersect(RList, RName.EntireColumn)
                If Trim(R.Value) <> "" Then ' 替换IsEmpty，覆盖空白文本情况
                    If (DateDiff("d", R.Value, Now)) >= 335 And (DateDiff("d", R.Value, Now)) < 365 Then
                            R.Interior.ColorIndex = 27 
                        sBodyOne = sBodyOne & vbNewLine & _
                            R.Offset(0, (-(R.Column - 1))) & ". You have " & (365 - (DateDiff("d", R.Value, Now))) & " days until it expires."
                        sWarnOne = vbNewLine & vbNewLine & "You are nearing expiration for the following equipment:" & vbNewLine
                    ElseIf (DateDiff("d", R.Value, Now)) > 365 Then
                        If (DateDiff("d", R.Value, Now)) > 425 Then
                            R.Interior.ColorIndex = 1 
                            sOverdue = "overdue"
                            sBodyTwo = sBodyTwo & vbNewLine & _
                                R.Offset(0, (-(R.Column - 1))) & ". You are " & ((DateDiff("d", R.Value, Now)) - 365) & " days overdue for retraining."
                            sWarnTwo = vbNewLine & vbNewLine & "Your certification has expired with the following equipment:" & vbNewLine
                        Else
                            R.Interior.ColorIndex = 3 
                            sOverdue = "overdue" 
                            sBodyTwo = sBodyTwo & vbNewLine & _
                                R.Offset(0, (-(R.Column - 1))) & ". You are " & ((DateDiff("d", R.Value, Now)) - 365) & " days overdue for retraining. You have " & (Abs((DateDiff("d", R.Value, Now)) - 425)) & " days before a full retraining is required."
                            sWarnTwo = vbNewLine & vbNewLine & "Your certification has expired with the following equipment:" & vbNewLine
                        End If
                    ElseIf (DateDiff("d", R.Value, Now)) < 335 Then
                        R.Interior.ColorIndex = 10
                    
                    End If

                Else
                    emptyCount = emptyCount + 1 '统计空单元格（含空白文本）
                
                End If
            Next
            End If
            
            If Not sBodyOne = "" Or Not sBodyTwo = "" Then
                Set EItem = EApp.CreateItem(0)
                With EItem
                  .To = RName.Offset(1, 0)
                  .Subject = "You're " & sOverdue & " for retraining and certification"
                  .body = "Hello, " & RName & vbNewLine & "This email is to remind you that your certification with Pilot Plant equipment is close to expiring, or has already expired." & sWarnOne & sBodyOne & sWarnTwo & sBodyTwo & vbNewLine & vbNewLine & "Contact for retraining."
                  .Display
                End With
            ElseIf emptyCount = 53 Then '现在计数为单个人员的空单元格数量，条件可正确触发
                Set EItem = EApp.CreateItem(0)
                With EItem
                    .To = RName.Offset(1, 0)
                    .Subject = "You are listed as an operator but have no certifications"
                    .body = "Hello, " & RName & vbNewLine & "You have been sent this email because you are listed as an operator, yet have no certifications with any equipment. Please reach out to schedule training, or to be removed from the operator list."
                    .Display ' 添加Display，确保邮件显示
                End With
            End If
            
            If emptyCount > 0 Then
                MsgBox (emptyCount) '调试用弹窗
            End If
            sBodyOne = vbNullString
            sBodyTwo = vbNullString
            sWarnOne = vbNullString
            sWarnTwo = vbNullString
            
        Next RName
        
        Set EApp = Nothing
        Set EItem = Nothing

    Case Else
        MsgBox "Incorrect Password"
End Select

End Sub

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