单元格变更时用VBA自动发送含对应行数据的邮件

DevOps 小满

2026-8-16

问题说明

我是编程新手，正在自学编程。现有一个包含员工姓名、邮箱等信息的大型表格，员工提交内容后由管理层通过下拉菜单选择approved或rejected完成审批。希望在管理层选择approved时，自动生成并发送邮件给对应员工，邮件需包含该行其他单元格信息。

找到的现有代码仅支持单行数据，无法在单元格变更时触发，也不知道如何实现：当H3选approved时发送第3行数据，H7选approved时发送第7行数据。

原代码如下：

Option Explicit
Dim Rng As Range
Sub Worksheet_Change(ByVal mRng As Range)
On Error Resume Next
If mRng.Cells.Count > 1 Then Exit Sub
Set Rng = Intersect(Range("H3:H1000"), mRng)
If Rng Is Nothing Then Exit Sub
If Target = ("J3:J1000") And Target.Value = "Approved" Then
Call ExcelToOutlook
End If
End Sub
Sub ExcelToOutlook()
Dim mApp As Object
Dim mMail As Object
Dim mMailBody As String
Set mApp = CreateObject("Outlook.Application")
Set mMail = mApp.CreateItem(0)
mMailBody = "Hi " & Range("B3") & vbNewLine & vbNewLine & _
"Your expert has been approved." & vbNewLine & vbNewLine & _
"See Row " & Range("A3") & vbNewLine & vbNewLine & _
"Name: " & Range("D3") & (" ") & Range("E3") & vbNewLine & vbNewLine & _
"Platform: " & Range("F3") & vbNewLine & vbNewLine & _
("Handle: ") & Range("G3") & vbNewLine & vbNewLine & _
"Notes: " & Range("I3") & vbNewLine & vbNewLine & _
"Thanks"
On Error Resume Next
With mMail
        .To = Range("C3")
        .CC = ""
        .BCC = ""
        .Subject = "Your expert has been " & Range("H3")
        .Body = mMailBody
        .Display 'or you can use .Send
End With
On Error GoTo 0
Set mMail = Nothing
Set mApp = Nothing
End Sub

修改后的代码

Option Explicit

' 工作表变更事件，监听H3:H1000的单元格修改
Sub Worksheet_Change(ByVal Target As Range)
    Dim changedRow As Long
    ' 禁止事件递归触发
    Application.EnableEvents = False
    
    On Error GoTo ErrorHandler
    ' 只处理单个单元格变更，且变更范围在H3:H1000内
    If Target.Cells.Count > 1 Then GoTo ExitSub
    If Intersect(Target, Range("H3:H1000")) Is Nothing Then GoTo ExitSub
    
    ' 仅当单元格值为"approved"（不区分大小写）时触发邮件发送
    If UCase(Target.Value) = "APPROVED" Then
        changedRow = Target.Row
        ' 调用邮件发送子程序，传入当前行号
        Call ExcelToOutlook(changedRow)
    End If

ExitSub:
    ' 恢复事件触发
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "发生错误：" & Err.Description
    Resume ExitSub
End Sub

' 邮件发送子程序，接收行号参数动态获取该行数据
Sub ExcelToOutlook(rowNum As Long)
    Dim mApp As Object
    Dim mMail As Object
    Dim mMailBody As String
    Dim ws As Worksheet
    
    Set ws = ActiveSheet ' 可替换为具体工作表名称，比如Sheet1
    
    ' 创建Outlook对象
    Set mApp = CreateObject("Outlook.Application")
    Set mMail = mApp.CreateItem(0)
    
    ' 动态拼接邮件内容，使用传入的行号引用对应单元格
    mMailBody = "Hi " & ws.Cells(rowNum, "B").Value & vbNewLine & vbNewLine & _
                "Your expert has been approved." & vbNewLine & vbNewLine & _
                "See Row " & ws.Cells(rowNum, "A").Value & vbNewLine & vbNewLine & _
                "Name: " & ws.Cells(rowNum, "D").Value & " " & ws.Cells(rowNum, "E").Value & vbNewLine & vbNewLine & _
                "Platform: " & ws.Cells(rowNum, "F").Value & vbNewLine & vbNewLine & _
                "Handle: " & ws.Cells(rowNum, "G").Value & vbNewLine & vbNewLine & _
                "Notes: " & ws.Cells(rowNum, "I").Value & vbNewLine & vbNewLine & _
                "Thanks"
    
    On Error Resume Next
    With mMail
        .To = ws.Cells(rowNum, "C").Value
        .CC = ""
        .BCC = ""
        .Subject = "Your expert has been " & ws.Cells(rowNum, "H").Value
        .Body = mMailBody
        .Display ' 测试阶段用Display，确认无误后改为.Send
    End With
    On Error GoTo 0
    
    ' 释放对象
    Set mMail = Nothing
    Set mApp = Nothing
    Set ws = Nothing
End Sub

关键修改说明

事件触发修正：原代码错误混用变量，已统一使用事件参数Target，并添加事件递归防护，避免重复触发。
动态行号传递：在变更事件中获取修改单元格的行号，传递给邮件发送子程序，实现对应行数据的动态引用。
单元格引用优化：使用ws.Cells(rowNum, 列标)的方式调用指定行的单元格值，不再固定第3行。
错误处理增强：添加错误捕获逻辑，避免程序崩溃并提示错误信息。

注意事项

确保Excel启用宏功能，文件需保存为.xlsm格式。
首次运行需允许Outlook的自动化访问权限。
测试阶段保留.Display查看邮件内容，确认无误后替换为.Send实现自动发送。

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