使用自动电子邮件宏下拉列表

Question

我正在尝试创建一个项目跟踪程序，该项目所属的利益相关者将在H列中。在工作表2中，我在D列下创建了具有利益相关者名称的列表验证，而E列具有其电子邮件地址。在工作表1中，我想自动发送电子邮件，在H列下拉列表中选择利益相关者是谁。

在电子邮件标题中，我希望它说“ Project Update：”和“”以及Range（“ $ b 2”）。Value 工作表1上的B2是项目名称。因此，对于每一行，当H列为利益相关者选择下拉菜单时，我希望它自动向他们发送一封电子邮件，并在主题行中显示其项目名称。

到目前为止，这是我所拥有的，但是还没有完成工作。请帮助MACRO Gods。

我在Sheet 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