需求：每月自动通过Outlook发送Excel逾期任务指定行邮件

核心逻辑 #

1. 筛选出截止日期早于当前日期的逾期任务
2. 按「负责人邮箱」分组整理每个用户的逾期任务
3. 为每个邮箱生成仅包含其本人逾期任务的HTML格式邮件，通过Outlook发送
4. 设置每月首日自动执行检查流程

完整VBA代码 #

打开Excel按Alt+F11进入VBA编辑器，插入新模块，粘贴以下代码：

Sub SendOverdueTaskEmails()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim taskDict As Object ' 用于按邮箱分组任务
    Dim emailKey As String
    Dim taskList As String
    Dim olApp As Object
    Dim olMail As Object
    Dim todayDate As Date
    
    ' 初始化变量
    Set ws = ThisWorkbook.Worksheets("任务表") ' 替换成你的工作表名称
    todayDate = Date
    Set taskDict = CreateObject("Scripting.Dictionary")
    
    ' 获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历数据，按邮箱分组逾期任务
    For i = 2 To lastRow ' 假设第1行是表头
        ' 检查是否逾期：截止日期列假设是D列，可根据实际调整
        If ws.Cells(i, "D").Value < todayDate And ws.Cells(i, "C").Value <> "" Then ' C列是邮箱，跳过空邮箱
            emailKey = ws.Cells(i, "C").Value
            ' 拼接任务信息：任务名称(A列)、负责人(B列)、截止日期(D列)
            taskList = "<tr><td>" & ws.Cells(i, "A").Value & "</td>" & _
                       "<td>" & ws.Cells(i, "B").Value & "</td>" & _
                       "<td>" & Format(ws.Cells(i, "D").Value, "yyyy-mm-dd") & "</td></tr>"
            
            ' 字典中已存在该邮箱，追加任务；不存在则新建条目
            If taskDict.Exists(emailKey) Then
                taskDict(emailKey) = taskDict(emailKey) & taskList
            Else
                taskDict(emailKey) = taskList
            End If
        End If
    Next i
    
    ' 初始化Outlook
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    ' 遍历字典，发送邮件
    For Each emailKey In taskDict.Keys
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = emailKey
            .Subject = "【逾期任务提醒】您有未完成的逾期任务"
            ' 生成HTML邮件内容
            .HTMLBody = "<p>您好，以下是您的逾期任务清单，请及时处理：</p>" & _
                        "<table border='1' cellpadding='5' cellspacing='0'>" & _
                        "<tr><th>任务名称</th><th>负责人</th><th>截止日期</th></tr>" & _
                        taskDict(emailKey) & "</table>" & _
                        "<p>感谢您的配合！</p>"
            .Send ' 直接发送，如需测试可改为.Display
        End With
        Set olMail = Nothing
    Next emailKey
    
    ' 清理对象
    Set olApp = Nothing
    Set taskDict = Nothing
    MsgBox "逾期任务提醒邮件已全部发送完成！", vbInformation
End Sub

' 设置每月首日自动运行（需结合Workbook_Open事件）
Sub SetMonthlySchedule()
    Dim nextRunDate As Date
    ' 计算下一个月的1号
    nextRunDate = DateSerial(Year(Date), Month(Date) + 1, 1)
    ' 取消之前的定时任务（避免重复）
    On Error Resume Next
    Application.OnTime EarliestTime:=nextRunDate, Procedure:="SendOverdueTaskEmails", Schedule:=False
    On Error GoTo 0
    ' 设置新的定时任务
    Application.OnTime EarliestTime:=nextRunDate, Procedure:="SendOverdueTaskEmails", Schedule:=True
End Sub

' 工作簿打开时自动设置定时任务
Private Sub Workbook_Open()
    SetMonthlySchedule
End Sub

代码关键部分解释 #

1. 字典分组：使用Scripting.Dictionary按邮箱聚合任务，确保每个用户只收到自己的逾期任务，避免批量发送重复内容
2. HTML邮件格式：生成带表格的邮件，比纯文本更易读，格式可根据需求调整（比如修改表格样式、添加公司标识等）
3. Outlook对象处理：先尝试获取已打开的Outlook实例，不存在则新建，避免重复启动Outlook
4. 自动触发逻辑：通过Application.OnTime设置每月1号自动执行，Workbook_Open事件确保每次打开文件时重新确认定时任务

注意事项 #

• 替换代码中的"任务表"为你的实际工作表名称
• 确认列对应关系：A=任务名称、B=负责人、C=邮箱、D=截止日期，可根据实际列位置调整代码中的列标识（比如把"D"改成"E"）
• 测试时可将.Send改为.Display，先预览邮件内容再发送
• 需确保Excel启用宏，且Outlook允许自动发送邮件（可能需要在Outlook信任中心设置允许宏）

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