отправка электронных писем после того, как значение встречается в столбце

Question

В настоящее время я создал код, который будет отправлять 1 электронное письмо конкретному человеку, как только в определенной ячейке будет найдено значение.

Мне нужно, чтобы макрос выполнял поиск во всем столбце (столбец E) иотправлять электронное письмо (адрес электронной почты, указанный в столбце D) каждый раз, когда значение встречается (в E), но только один раз на идентификационный номер (находится в столбце C)

example:
   A        B       C        D                        E      F    G
   John     Smith   123659   john.smith@gmail.com     330    NB   Moncton
   John     Smith   123659   john.smith@gmail.com     330    NB   Shediac

, чтобы выходило только одно электронное письмопоскольку встречаемое значение равно 330, и обе записи принадлежат одному и тому же идентификационному номеру

, это код, который у меня есть в настоящее время, но он специфичен для ячейки

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Cells.Count > 1 Then Exit Sub
  If Not Application.Intersect(Range("E2"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value = 330 Then
        Call renewalemail
    End If
  End If
End Sub

Sub renewalemail()


Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)


xMailBody = "Hi," & vbNewLine & vbNewLine & _
            "Your registration to the National Transfer Inventory is up for renewal" & vbNewLine & _
            "Every year, you are required to review your selection(s) and renew your registration" & vbNewLine & vbNewLine & _
            "Please refer to the frequently asked questions (FAQ) document for more details (RDIMS# 5757800)" & vbNewLine & vbNewLine & _
            "Thank you"


            On Error Resume Next
With xOutMail
    .SentOnBehalfOfName = "XXX.ServiceCentre-CentredeService.XXX@gmail.com"
    .To = Sheets("Inventory").Range("D2").Value
    .CC = ""
    .BCC = ""
    .Subject = "RENEWAL NOTIFICATION - National Transfer Inventory / AVIS de RENOUVELLEMENT - Répertoire de Mutation"
    .Body = xMailBody
    .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing

End Sub

Любая помощь будет принята с благодарностью

спасибо

 Sub Cmdrenewal_Click()

   Dim ws As Worksheet
   Dim r As Range

 Set ws = Worksheets("Inventory")

   With ws


    lr = .Range("C" & Rows.Count).End(xlUp).Row

    For I = lr To 1 Step -1
    If .Cells(I, "S") = 383 Then
    Call renewalemail
    End If

  Next I

  End With

  On Error Resume Next
 End Sub

Answer 1

Сохраните идентификатор. Есть много способов сделать это:

• Храните их в строке, разделенной "," или ";" или любой другой символ, который вы хотите, затем разделите его и итерируйте массив
• Узнайте, как работают словари: https://excelmacromastery.com/vba-dictionary/

Или просто удалите дубликаты на основе столбца C.