Excel'de yalnızca bir sütundan benzersiz adresler için e-postaları nasıl oluşturabilirim?

Question

Şu anda, müşterilere gönderilecek patlama e-postaları oluşturmaya çalışıyorum ve sütun listesinde bazı yinelenen e-posta adresleri var. Her bir e-posta adresine yalnızca bir e-posta göndermek istiyorum, ancak makronumu çalıştırdığımda, sütunda daha önce/sonraki bir adresin tekrar edilmesine bakılmaksızın, sütundaki her hücre için bir e-posta oluşturur. Benim kod snippet'idir aşağıdaki gibidir:

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 işlevi nezaket