如果收件人电子邮件相同，则合并电子邮件主题和正文

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