drop-down-menu - 使用自动电子邮件宏下拉

Question

我正在尝试创建一个项目跟踪器，项目所属的利益相关者将在 H 列中。在表 2 中，我在 D 列下使用利益相关者姓名创建了列表验证，E 列有他们的电子邮件地址。我想在表 1 中自动发送电子邮件，H 列下拉选择利益相关者是谁。

在电子邮件标题中，我希望它说“项目更新：”&“”& Range("$b 2")。工作表 1 上的值 B2 是项目名称。因此，对于每一行，当 H 列为利益相关者选择下拉列表时，我希望它自动向他们发送一封电子邮件，主题行中包含他们的项目名称。

这是我到目前为止所拥有的，但它并没有完成工作。请帮助宏神。

我在工作表 1 VBA 中有以下内容

Option Explicit
Public MailADD As String
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
    SendMe
    End If
    End Sub

然后在模块 1 中，我有以下内容。

Sub SendMe()
  Dim IsCreated As Boolean
  Dim i As Long
  Dim Title As String
  Dim OutlApp As Object
  Dim HyperlinkMe As String
  Dim fnd As String
  Dim Rng As Range
  Dim MailADD As String

  With ActiveSheet
      fnd = Range("H1").Value
    If fnd <> "" Then
        With Sheets("Sheet2").Range("B:B")
            Set Rng = .Find(What:=fnd, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                MailADD = Rng.Offset(, 1).Value
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
    fnd = Range("b1").Value
    HyperlinkMe = Range("l1").Value

    Selection.Font.Bold = True
    Selection.Font.Underline = xlUnderlineStyleSingle
    Title = "Project Update: " & " " & Range("$b2").Value

  On Error Resume Next
  Set OutlApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  OutlApp.Visible = True
  On Error GoTo 0

  With OutlApp.CreateItem(0)

    .Subject = Title
    .To = MailADD
    .CC = ""
    .Body = "Hello," & vbLf & "Please review the link below of the BA CCS Project tracker for an update on your project" & vbLf & vbLf & HyperlinkMe & vbLf & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf


    On Error Resume Next
    .Display
    '.Send
    'Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0

 If IsCreated Then OutlApp.Quit

End With
  Set OutlApp = Nothing
End With
End Sub

标签： drop-down-menumacrosemail-validation