如何更改 Excel 中的代码以根据特定单元格中的下拉答案向特定人员发送电子邮件？

Question

下面是我在Excel设计模式（宏）中使用的代码。目前，我已将所有经理复制到回复电子邮件中。我宁愿将单元格 P2 的内容（“选择您的工作区域”）直接复制到该电子邮件的位置（例如“Snow Camp (3-6)”复制到 Melissa 的电子邮件中。我知道代码很混乱。我还没有'从 7 年级开始就没有写过代码（我现在 50 多岁了）。非常感谢任何帮助。

样本表格：

Private Sub CommandButton1_Click()
Dim xOutlookObj As Object
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.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")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & Filename & xFile, FileFormat:=xFormat
With OutlookMail
.To = "[email protected]"
.CC = "[email protected];[email protected];[email protected];" & Range("k7").Value
.BCC = ""
.Subject = "2024-25 Schedule - " & Range("E3").Value
.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 - [email protected]" & vbNewLine & _
    "**Mountain Camp - [email protected]" & vbNewLine & _
    "**Privates & Adults - [email protected]" & vbNewLine & _
vbNewLine & _
    "Thank you for submitting your schedule. Refresher weekend is November 2nd & 3rd. We hope to see you there!" & vbNewLine & _
vbNewLine & _
    "***Think Snow***"
On Error Resume Next
.Attachments.Add Wb2.FullName
.Display   'or use .Send
End With
Wb2.Close
Kill FilePath & Filename & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub

我尝试将下面的一些代码添加到“On Error Resume Next”行下方的代码中，但出现错误。我试图触发梅丽莎的电子邮件，但也将员工的姓氏添加到电子邮件主题行中。如果可以通过其他方式触发电子邮件，我很乐意删除“提交”按钮。

Dim xRg As Range
Private Sub Worksheet_Change(Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("P2"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > "Snow Camp (3-6)"Then
        Call Mail_small_Text_Outlook
With OutlookMail
.To = "[email protected]"
.CC = "[email protected];" & Range("k7").Value
.BCC = ""
.Subject = "2024-25 Schedule - " & Range("E3").Value

Answer 1

您可以使用

Select Case

语句根据单元格 P2 的值动态设置

.CC

属性。您将在配置电子邮件属性（例如，

.To

、

.CC

等）之前插入此逻辑。现在，要根据单元格更改触发电子邮件，我将使用不同的策略。

首先，让我们修复

CommandButton1_Click

过程，以根据单元格 P2 中的下拉菜单动态设置 CC。假设单元格 P2 包含工作区域的名称（例如“Snow Camp (3-6)”），您可以执行以下操作：

Private Sub CommandButton1_Click()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim xMailBody As String
    Dim ccEmail As String
    
    ' Your existing setup code for the workbook, worksheet, etc.
    
    ' Determine the CC email based on the dropdown in P2
    Select Case Range("P2").Value
        Case "Snow Camp (3-6)"
            ccEmail = "[email protected]"
        Case "Mountain Camp"
            ccEmail = "[email protected]"
        Case "Privates & Adults"
            ccEmail = "[email protected]"
        Case Else
            ccEmail = "" ' Default or a fallback email
    End Select
    
    ' Your existing code to create Outlook objects
    
    With OutlookMail
        .To = "[email protected]"
        .CC = ccEmail & ";" & Range("k7").Value ' Use the dynamically determined CC
        ' Your existing code for BCC, Subject, Body, etc.
    End With
    
    ' Your existing code to finalize the email and clean up
End Sub

要根据特定单元格（如 P2）的更改触发电子邮件，您通常会在工作表的代码模块中使用

Worksheet_Change

事件，而不是在与按钮单击事件相同的代码中使用。这种方法需要仔细考虑，特别是在用户体验和无意发送电子邮件的可能性方面。这是一个如何开始的简化示例：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("P2")) Is Nothing Then
        ' Call your mail function here, or place a simplified version of the mail sending code directly here
        ' Be cautious with this to prevent accidental email sends
    End If
End Sub

如果不仔细管理，基于单元格更改的自动电子邮件发送可能会导致大量意外电子邮件。在自动发送电子邮件之前，请考虑添加额外的检查或确认。

版主请注意：我使用 Typora Markdown 编辑器编辑我的帖子，然后复制并粘贴到此处。别再认为我不是人了。这真是令人沮丧。