Excel VBA按单元格P2下拉值设置邮件抄送及问题排查

当前Excel VBA按钮触发的邮件会抄送所有经理，需要实现以下优化：

• 根据P2单元格（「选择工作区域」）的下拉选项动态指定抄送对象（例如选「Snow Camp (3-6)」时仅抄送Melissa的邮箱）
• 邮件主题中加入员工姓氏
• 移除提交按钮，改用单元格内容变化自动触发邮件发送

原尝试的Worksheet_Change事件代码存在逻辑错误（如用数值判断文本、调用未定义过程、代码不完整），以下是修正后的完整实现：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅当修改的是P2单元格时执行
    If Target.Address <> "$P$2" Then Exit Sub
    ' 避免批量修改或公式触发误执行
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub

    Dim Wb As Workbook, Wb2 As Workbook
    Dim OutlookApp As Object, OutlookMail As Object
    Dim xFile As String, xFormat As XlFileFormat
    Dim FilePath As String, Filename As String
    Dim ccRecipients As String
    Dim employeeFullName As String, employeeLastName As String

    On Error GoTo Cleanup ' 错误处理，避免临时文件残留

    ' 获取员工姓名并提取姓氏（假设E3是全名，按空格拆分取最后一段）
    employeeFullName = Range("E3").Value
    If InStr(employeeFullName, " ") > 0 Then
        employeeLastName = Split(employeeFullName, " ")(UBound(Split(employeeFullName, " ")))
    Else
        employeeLastName = employeeFullName ' 若没有空格则直接用全名
    End If

    ' 根据P2的工作区域设置抄送对象
    Select Case Target.Value
        Case "Snow Camp (3-6)"
            ccRecipients = "melissa.s.evans@vailresorts.com;" & Range("K7").Value
        Case "Mountain Camp"
            ccRecipients = "douglas.s.kaufman@vailresorts.com;" & Range("K7").Value
        Case "Privates & Adults"
            ccRecipients = "David.Isaacs@vailresorts.com;" & Range("K7").Value
        Case Else
            ' 默认抄送所有经理（可选保留）
            ccRecipients = "melissa.s.evans@vailresorts.com;douglas.s.kaufman@vailresorts.com;David.Isaacs@vailresorts.com;" & Range("K7").Value
    End Select

    ' 复制当前工作表为临时工作簿
    Set Wb = ThisWorkbook
    ActiveSheet.Copy
    Set Wb2 = ActiveWorkbook

    ' 匹配原工作簿的文件格式
    Select Case Wb.FileFormat
        Case xlOpenXMLWorkbook:
            xFile = ".xlsx"
            xFormat = xlOpenXMLWorkbook
        Case xlOpenXMLWorkbookMacroEnabled:
            If Wb2.HasVBProject Then
                xFile = ".xlsm"
                xFormat = xlOpenXMLWorkbookMacroEnabled
            Else
                xFile = ".xlsx"
                xFormat = xlOpenXMLWorkbook
            End If
        Case Excel8:
            xFile = ".xls"
            xFormat = Excel8
        Case xlExcel12:
            xFile = ".xlsb"
            xFormat = xlExcel12
    End Select

    ' 生成临时文件路径和名称
    FilePath = Environ$("temp") & "\"
    Filename = Wb.Name & Format(Now, "dd-mmm-yy")
    Wb2.SaveAs FilePath & Filename & xFile, FileFormat:=xFormat

    ' 创建并配置Outlook邮件
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .To = "DiscoveryCenterRentals@vailresorts.com"
        .CC = ccRecipients
        .BCC = ""
        ' 主题加入员工姓氏
        .Subject = "2024-25 Schedule - " & employeeFullName & " (" & employeeLastName & ")"
        .Body = "Please be sure to save a copy of your schedule for reference." & vbNewLine & _
          vbNewLine & _
          "You can reach out to your Core Area manager after October 1st:" & vbNewLine & _
          "**Snow Camp - Melissa.S.Evans@VailResorts.com" & vbNewLine & _
          "**Mountain Camp - Douglas.S.Kaufman@VailResorts.com" & vbNewLine & _
          "**Privates & Adults - David.Isaacs@VailResorts.com" & vbNewLine & _
          vbNewLine & _
          "Thank you for submitting your schedule. Refresher weekend is November 2nd & 3rd. We hope to see you there!" & vbNewLine & _
          vbNewLine & _
          "***Think Snow***"
        .Attachments.Add Wb2.FullName
        .Display ' 改为.Send可直接发送，无需手动点击
    End With

Cleanup:
    ' 清理临时文件和对象
    If Not Wb2 Is Nothing Then Wb2.Close SaveChanges:=False
    If FilePath <> "" And Filename <> "" And xFile <> "" Then
        On Error Resume Next
        Kill FilePath & Filename & xFile
        On Error GoTo 0
    End If
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Set Wb2 = Nothing
    Set Wb = Nothing
End Sub

关键修改说明 #

• 触发逻辑：仅当P2单元格内容变化时执行，避免批量修改或其他单元格操作误触发
• 动态抄送：通过Select Case匹配P2的下拉值，精准设置对应经理的邮箱，同时保留原逻辑中的K7单元格抄送
• 主题优化：从E3单元格提取员工姓氏，加入到邮件主题中（若E3格式不是「名 姓」，可调整拆分逻辑）
• 错误处理：新增Cleanup标签，确保无论是否出错都会清理临时文件和释放对象，避免文件残留
• 移除按钮：直接用Worksheet_Change事件替代原按钮触发，无需手动点击提交

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