如何通过VBA向特定员工发送其分配的每日任务邮件

以下是适配你需求的VBA代码，实现工作簿保存后，自动给每位员工发送包含其专属任务的邮件：

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xTaskWs As Worksheet ' 任务分配工作表
    Dim xMailWs As Worksheet ' 员工邮箱对照表
    Dim xLastRow As Long, xRow As Long, xTaskStartRow As Long
    Dim xEmpName As String, xEmpEmail As String
    Dim xTaskList As String, xTaskRow As Long
    
    ' 请根据实际工作表名称修改下面的名称
    Set xTaskWs = ThisWorkbook.Worksheets("任务分配")
    Set xMailWs = ThisWorkbook.Worksheets("员工邮箱")
    
    ' 仅在保存成功时执行邮件发送
    If Not Success Then Exit Sub
    
    On Error Resume Next
    Set xOutApp = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then
        MsgBox "无法启动Outlook，请检查是否已安装", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    xLastRow = xTaskWs.Cells(xTaskWs.Rows.Count, "A").End(xlUp).Row
    xRow = 1
    
    ' 遍历任务表，提取每位员工的信息
    Do While xRow <= xLastRow
        ' 跳过空行
        If Trim(xTaskWs.Cells(xRow, "A").Value) = "" Then
            xRow = xRow + 1
            Continue Do
        End If
        
        ' 获取员工姓名
        xEmpName = xTaskWs.Cells(xRow, "A").Value
        xTaskStartRow = xRow
        xTaskList = ""
        
        ' 收集该员工的所有任务
        Do
            If Trim(xTaskWs.Cells(xTaskStartRow, "B").Value) <> "" Then
                xTaskList = xTaskList & "- " & xTaskWs.Cells(xTaskStartRow, "B").Value & Chr(13) & Chr(13)
            End If
            xTaskStartRow = xTaskStartRow + 1
            ' 直到遇到空行或下一个员工姓名（A列有内容）
        Loop Until xTaskStartRow > xLastRow Or Trim(xTaskWs.Cells(xTaskStartRow, "A").Value) <> ""
        
        ' 在邮箱表中查找员工对应的邮箱
        xEmpEmail = ""
        On Error Resume Next
        xEmpEmail = xMailWs.Range("A:A").Find(What:=xEmpName, LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 1).Value
        On Error GoTo 0
        
        ' 如果找到邮箱，创建并发送邮件
        If xEmpEmail <> "" Then
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .To = xEmpEmail
                .Subject = "你的任务分配通知"
                .Body = "Hi " & xEmpName & "," & Chr(13) & Chr(13) & "以下是你的当前任务：" & Chr(13) & Chr(13) & xTaskList & "请查收附件中的最新文件。"
                .Attachments.Add ThisWorkbook.FullName
                .Display ' 测试时用Display，正式使用可改为.Send
            End With
            Set xMailItem = Nothing
        Else
            MsgBox "未找到员工" & xEmpName & "的邮箱地址，请检查员工邮箱表", vbExclamation
        End If
        
        ' 跳转到下一个员工的行
        xRow = xTaskStartRow
    Loop
    
    Set xOutApp = Nothing
    Set xTaskWs = Nothing
    Set xMailWs = Nothing
End Sub

关键说明 #

• 工作表名称修改：请将代码中的"任务分配"和"员工邮箱"替换为你实际的工作表名称
• 邮箱表格式要求：员工邮箱表需满足A列为姓名，B列为对应邮箱，且姓名与任务表中的姓名完全一致（区分大小写）
• 任务收集逻辑：自动识别每位员工的任务范围（从姓名行开始，直到下一个姓名行或空行结束），并将任务整理为带项目符号的列表
• 错误处理：增加了Outlook启动失败、邮箱未找到的提示，避免代码崩溃
• 发送控制：默认使用.Display显示邮件方便测试，确认无误后可改为.Send自动发送

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