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

Question

Я использую приведенный ниже код для отправки электронной почты из Excel, когда пользователь нажимает кнопку. это работает отлично. Я на самом деле хочу настроить это, потому что сейчас происходит, когда в столбце C есть дублирующее электронное письмо, а в столбце N - все да, генерируются отдельные электронные письма. то, что я хочу сделать, это если в столбце C есть дубликат электронного письма, то должно быть сгенерировано одно электронное письмо с темой и телом из повторяющихся строк

Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next

LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then

Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
            Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
          "were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
          "This is a system generated email and doesn't require signature"
              On Error Resume Next
With xOutMail
    .To = Cells(Cell.Row, 3)
    .CC = Cells(Cell.Row, 5)
    .BCC = ""
    .Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
    .Body = xMailBody
    '.Attachments.Add ActiveWorkbook.FullName
    .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell

Answer 1

Вы можете попробовать:

Option Explicit

Public Sub Get_Unique_Count_Paste_Array()

    Dim Ob As Object
    Dim rng As Range
    Dim LR As Long
    Dim str As String

    With Worksheets("Sheet1")

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

        Set Ob = CreateObject("scripting.dictionary")

        For Each rng In .Range("C8:C" & LR)
            str = Trim(rng.Value)
            If Len(str) > 0 Then
                Ob(str) = Ob(str) + 1
                    If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
                        MsgBox str '<= Insert your code here
                    End If
            End If
        Next rng

    End With

End Sub