如何修改VBA脚本实现单邮箱发送多设备认证提醒邮件

原VBA脚本会为操作员的每台过期/即将过期设备单独发送邮件，导致同一操作员收到多封重复提醒。以下是修改后的脚本，实现按操作员汇总所有需重新认证的设备信息，仅发送单封提醒邮件：

Sub AutoMailer()
    Dim EApp As Object
    Set EApp = CreateObject("Outlook.Application")
    
    ' 用字典存储每个操作员的邮件相关信息，避免重复发送
    Dim operatorDict As Object
    Set operatorDict = CreateObject("Scripting.Dictionary")
    
    Dim RList As Range
    Set RList = Range("C4", "BZ50")
    Dim R As Range
    Dim operatorEmail As String, operatorName As String, deviceName As String
    Dim daysLeft As Integer, overdueDays As Integer
    Dim mailSubject As String, mailBodyPart As String
    Dim currentInfo As Variant
    
    For Each R In RList
        If Not IsEmpty(R) Then
            ' 获取当前行的操作员邮箱、姓名，以及当前列的设备名称
            operatorEmail = R.Offset(, -(R.Column - 2)).Value
            operatorName = R.Offset(, -(R.Column - 1)).Value
            deviceName = R.Offset(-(R.Row - 3), 0).Value
            
            ' 判断认证状态，生成对应提醒内容
            If DateDiff("d", R.Value, Now) >= 335 And DateDiff("d", R.Value, Now) < 365 Then
                R.Interior.ColorIndex = 27 ' 标记即将过期的单元格为黄色
                daysLeft = 365 - DateDiff("d", R.Value, Now)
                mailBodyPart = "- " & deviceName & ": 即将过期，剩余 " & daysLeft & " 天" & vbNewLine
                mailSubject = "您的设备认证即将到期，需重新培训"
            ElseIf DateDiff("d", R.Value, Now) > 365 Then
                R.Interior.ColorIndex = 3 ' 标记已过期的单元格为红色
                overdueDays = DateDiff("d", R.Value, Now) - 365
                mailBodyPart = "- " & deviceName & ": 已过期，逾期 " & overdueDays & " 天" & vbNewLine
                mailSubject = "您的设备认证已过期，需立即重新培训"
            Else
                ' 未到提醒时间，跳过当前单元格
                GoTo NextCell
            End If
            
            ' 将设备信息存入对应操作员的字典条目
            If Not operatorDict.Exists(operatorEmail) Then
                ' 首次添加该操作员，初始化信息数组：姓名、邮件主题、设备提醒列表
                operatorDict(operatorEmail) = Array(operatorName, mailSubject, mailBodyPart)
            Else
                ' 已有该操作员，追加设备信息，同时优先使用更紧急的邮件主题
                currentInfo = operatorDict(operatorEmail)
                If mailSubject = "您的设备认证已过期，需立即重新培训" Then
                    currentInfo(1) = mailSubject
                End If
                currentInfo(2) = currentInfo(2) & mailBodyPart
                operatorDict(operatorEmail) = currentInfo
            End If
        End If
NextCell:
    Next R
    
    ' 遍历字典，为每个操作员发送汇总邮件
    Dim key As Variant
    Dim EItem As Object
    For Each key In operatorDict.Keys
        currentInfo = operatorDict(key)
        Set EItem = EApp.CreateItem(0)
        With EItem
            .To = key
            .Subject = currentInfo(1)
            .Body = "您好，" & currentInfo(0) & vbNewLine & vbNewLine _
                  & "以下设备的认证需要您重新培训：" & vbNewLine & vbNewLine _
                  & currentInfo(2) & vbNewLine _
                  & "请及时完成认证，避免影响工作。"
            .Display ' 测试阶段用Display预览，正式使用可改为.Send直接发送
        End With
        Set EItem = Nothing
    Next key
    
    ' 释放对象
    Set EApp = Nothing
    Set operatorDict = Nothing
End Sub

关键修改说明 #

• 字典分组存储：通过Scripting.Dictionary以操作员邮箱为唯一键，集中存储每个操作员的所有待认证设备信息，从根源避免重复发送邮件。
• 延迟发送逻辑：遍历单元格时仅收集信息，不触发邮件发送，等所有设备信息处理完成后，统一为每个操作员生成汇总邮件。
• 主题优先级处理：如果操作员同时存在即将过期和已过期的设备，邮件主题自动切换为"已过期"的紧急提醒，突出优先级。
• 保留原有标记功能：完整保留了原脚本中对即将过期、已过期单元格的着色逻辑，方便表格可视化查看。

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