如果收件人電子郵件相同，則合並電子郵件主題和正文

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