Раскрыть с помощью автоматической электронной почты Макро

Question

Я пытаюсь создать средство отслеживания проекта, и заинтересованная сторона, которой принадлежит проект, будет находиться в столбце H. На листе 2 я создал проверку списка в столбце D с именами заинтересованных сторон, а в столбце E указан адрес электронной почты. Я хочу автоматически отправлять электронное письмо, когда на листе 1 в раскрывающемся столбце H выбирается тот, кто является заинтересованным лицом.

В заголовке электронного письма я хочу, чтобы оно говорило «Обновление проекта:» & «« & Range (»). $ b 2 "). Значение B2 на листе 1 является названием проекта. Поэтому для каждой строки, когда в столбце H выбран выпадающий список для заинтересованного лица, я хочу, чтобы он автоматически отправлял им электронное письмо с именем проекта в строке темы.

Это то, что я имею до сих пор,но это не делает работу. Пожалуйста, помогите MACRO Gods.

У меня есть следующее в Листе 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