Excel单元格变色触发带附件邮件的VBA代码问题

需求说明 #

当Excel单元格颜色变更时自动发送带附件的邮件，不同变色单元格需提取对应位置的信息填充邮件内容：

• 修改C7单元格颜色：提取A8、C5、B3的数据，生成内容「Shariffa, 2 Aug 23」
• 修改H31:K31区域单元格颜色：提取A31、H29:K29、B27的数据，生成内容「Rae, 7 to 10 Nov 23」

原始代码问题分析 #

你提供的Worksheet_SelectionChange事件代码存在以下问题：

1. 事件触发逻辑错误：该事件是选中单元格时触发，而非单元格颜色变更时触发
2. Range对象赋值错误：Set xDateSelected = Range("date1").Value语法错误，应直接引用Range对象
3. 缺少指定单元格区域的分支处理：未针对C7和H31:K31编写对应的数据提取逻辑
4. 动态偏移找数据的逻辑不符合需求：需求是固定位置提取数据，而非通过偏移找非空单元格

修正后的VBA代码 #

步骤1：初始化颜色日志表 #

首先插入一个新工作表，命名为ColorLog，用于存储单元格原始颜色（解决Excel无直接颜色变更事件的问题），运行以下宏初始化日志：

Sub InitializeColorLog()
    Dim ws As Worksheet
    Dim cell As Range
    Set ws = ThisWorkbook.Worksheets("ColorLog")
    ws.Cells.Clear
    For Each cell In Me.UsedRange
        ws.Cells(cell.Row, cell.Column).Value = cell.Interior.Color
    Next cell
End Sub

步骤2：颜色变更触发邮件的事件代码 #

在目标工作表的模块中编写以下代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody As String
    Dim staffName As String
    Dim leaveDate As String
    Dim colorLogWs As Worksheet
    Dim originalColor As Long
    
    On Error GoTo Cleanup
    
    Set colorLogWs = ThisWorkbook.Worksheets("ColorLog")
    originalColor = colorLogWs.Cells(Target.Row, Target.Column).Value
    
    '仅当单元格变为红色（RGB(255,0,0)）时触发
    If Target.Interior.Color = RGB(255, 0, 0) And originalColor <> RGB(255, 0, 0) Then
        '更新颜色日志
        colorLogWs.Cells(Target.Row, Target.Column).Value = RGB(255, 0, 0)
        
        '根据不同单元格区域提取对应数据
        Select Case True
            Case Target.Address = "$C$7"
                staffName = Me.Range("A8").Value
                leaveDate = Me.Range("C5").Value & " " & Me.Range("B3").Value
            Case Not Intersect(Target, Me.Range("H31:K31")) Is Nothing
                staffName = Me.Range("A31").Value
                leaveDate = Me.Range("H29").Value & " to " & Me.Range("K29").Value & " " & Me.Range("B27").Value
            Case Else
                '其他单元格变色，不处理
                GoTo Cleanup
        End Select
        
        '生成邮件内容
        xMailBody = "Hi there Priscilla" & vbNewLine & vbNewLine & _
                    "Name: " & staffName & " is applying for Ad-hoc leave on " & leaveDate & vbNewLine & vbNewLine & _
                    "Reason: " & vbNewLine & vbNewLine & _
                    "Thank you" & vbNewLine
        
        '创建并发送邮件
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        
        With xMailItem
            .To = "foong.jia.yi1@nhcs.com.sg"
            .Subject = "Applying for Ad-hoc leave - " & staffName
            .Body = xMailBody
            .Attachments.Add ThisWorkbook.FullName
            .Display '如需自动发送，替换为.Send（需配置Outlook信任设置）
        End With
    End If
    
Cleanup:
    '释放对象
    Set xOutApp = Nothing
    Set xMailItem = Nothing
    Set colorLogWs = Nothing
End Sub

使用说明 #

1. 插入并命名工作表为ColorLog
2. 运行InitializeColorLog宏，完成单元格颜色日志初始化
3. 手动将C7或H31:K31区域的单元格设置为红色时，将自动触发邮件发送

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