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

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

1 个答案: