VBA Excel 宏在 Outlook 上發送電子郵件

Question

我制作了以下代碼以在 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

為 A1 中的每個單元格發送一封電子郵件都有一個 ID，如果我有 2 個具有相同 ID 的單元格，則在表中為同一封電子郵件發送 2 封不同的電子郵件。

優秀表格

我想驗證一下，如果 ID 相同，則只發送一封電子郵件而不是發送 2 封。

Answer 1

使用Dictionary對象來保存唯一 ID 並確保您不會發送重復的電子郵件

這是一個可能的代碼以及對原始代碼和建議的一些評論重構：

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