如何仅为 excel 列中的唯一地址创建电子邮件？

Question

目前，我正在尝试创建要发送给客户的爆炸电子邮件，并且列列表中有一些重复的电子邮件地址。我只想向每个唯一的电子邮件地址发送一封电子邮件，但是当我运行我的宏时，它会为列中的每个单元格创建一封电子邮件，无论该列中早先/晚的地址是否重复。 我的代码的 sn-p 如下：

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

    Set sh = Sheets("TestSheet")

    Set OutApp = CreateObject("Outlook.Application")    

For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)

    Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")

        If cell.Value Like "?*@?*.?*" And _
            Application.WorksheetFunction.CountA(rng) > 0 Then

                Set OutMail = OutApp.CreateItem(0)
                Set Entity = cell.Offset(0, -3)
                Set Quarter = cell.Offset(0, -2)
                Set Year = cell.Offset(0, -1)
                Set CCRecip = cell.Offset(0, 1)

                    strbody = "<font face = 'Calibri'><b>Hello All--</b>" & ...

                    signature = "<br>Thank you,<br>" & ...

                        .To = cell.Value
                        .CC = CCRecip.Value
                        .Subject = Entity.Value 
                        .HTMLBody = strbody & signature             
                        .display
                    End With                  
                Set OutMail = Nothing

        End If

Next cell

Answer 1

 Dim myColl As Collection
 Set myColl = New Collection

 With Application
     .EnableEvents = False
     .ScreenUpdating = False
 End With

 Set sh = Sheets("TestSheet")

 Set OutApp = CreateObject("Outlook.Application")    

 For Each cell In sh.Columns("D").Cells.SpecialCells(xlCellTypeConstants)

     Set rng = sh.Cells(cell.Row, 1).Range("E1:Z1")

     If cell.Value Like "?*@?*.?*" And _
        Application.WorksheetFunction.CountA(rng) > 0 Then
         If Not Contains(myColl, CStr(cell.Value)) Then
                 myColl.Add CStr(cell.Value), CStr(cell.Value)
                 Set OutMail = OutApp.CreateItem(0)
                 Set Entity = cell.Offset(0, -3)
                 Set Quarter = cell.Offset(0, -2)
                 Set Year = cell.Offset(0, -1)
                 Set CCRecip = cell.Offset(0, 1)

                 strbody = "<font face = 'Calibri'><b>Hello All--</b>" & ...

                 signature = "<br>Thank you,<br>" & ...

                    .To = cell.Value
                    .CC = CCRecip.Value
                    .Subject = Entity.Value 
                    .HTMLBody = strbody & signature             
                    .display
                End With                  
                Set OutMail = Nothing

         End If
    End If

 Next cell

 End Sub

 Public Function Contains(col As Collection, key As Variant) As Boolean
     Dim obj As Variant
     On Error GoTo err
     Contains = True
     obj = col(key)
     Exit Function
 err:

     Contains = False
 End Function

包含由 Vadim here 提供的功能