VBA Excel 宏在 Outlook 上发送电子邮件

Question

I made the code below to send an email in Outlook

Sub test()
    count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
    i = 2
    Do While i <= count
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        strbody = "Hello"
        On Error Resume Next
        With OutMail
            .SentOnBehalfOfName = "abc@abc.com"
            .to = Sheets("Sheet1").Cells(i, 4).Value
            .CC = Sheets("Sheet1").Cells(i, 3).Value
            .BCC = ""
            .Subject = Sheets("Sheet1").Cells(i, 1).Text & " " & Sheets("Sheet1").Cells(i, 2)
            .HTMLBody = strbody & .HTMLBody
            .Send
        End With
        On Error GoTo 0
        
        Set OutMail = Nothing
        Set OutApp = Nothing
        
        i = i + 1
        
    Loop
End Sub

Is sending one email for each cell in A1 have an ID,and in the table if I have 2 cells with same ID is sending 2 different emails for the same email.

excell table

I would like to make a verification that if the id is the same send just one email instead of sending 2.

Answer 1

Use a Dictionary object to hold unique IDs and ensure you're not sending duplicated emails

here's a possible code along with some commented refactoring of your original code and suggestions:

Option Explicit

Sub SendEmails()

    Dim IDsDict As Object
        Set IDsDict = CreateObject("Scripting.Dictionary") ' set a new Dictionary object to hold unique IDs to check

        With ThisWorkbook
            With .Worksheets("Sheet1")
                With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) ' reference all column A cells from row 1 down to last not empty one
                                    
                    If WorksheetFunction.Count(.Cells) > 0 Then ' if any not empty ID (they are numbers -> use Count() so as to leave "ID" header (a string) out from the total)
                        
                        Dim strbody As String
                            strbody = "Hello"
                        Dim OutApp As Object
                            Set OutApp = CreateObject("Outlook.Application") ' create one Outlook instance only for all mails
                            Dim cel As Range
                                For Each cel In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) ' loop through column A cells with numbers only
                                    
                                    If Not IDsDict.exists(cel.Value) Then 'if current ID is not in IDs dictionary already
                                    
                                        IDsDict.Add cel.Value, 0 ' add the current ID to IDs dictionary keys to possibly detect its duplicates in following rows
                                        
    '                                    On Error Resume Next ' why you need that?
                                        With OutApp.CreateItem(0)
                                            .SentOnBehalfOfName = "abc@abc.com"
                                            .to = cel.Offset(, 3).Value
                                            .CC = cel.Offset(, 2).Value
                                            .BCC = ""
                                            .Subject = cel.Text & " " & cel.Offset(, 1).Value
                                            .HTMLBody = strbody & .HTMLBody
                                            .Send
                                        End With
    '                                    On Error GoTo 0
                    
                                    End If
                        
                                Next
                                
                                    OutApp.Quit 'close Outlook
                                    Set OutApp = Nothing
                    
                    End If
                    
                End With
            End With
        End With
        
End Sub