VBA多收件人邮件发送问题求助：同一客户多邮箱仅发一次

Hey there! Let's tackle this email-sending issue you're facing with your VBA macro. The core problem here is that your current code is likely grouping emails by client ID and only sending one message per client, instead of one per unique email tied to that client. Let's break down how to fix this with common scenario fixes and clear code adjustments.

First, Diagnose the Root Cause #

Most often, this bug happens because your code is tracking only client IDs to avoid duplicate sends, rather than tracking the unique combination of client ID + email address. This means even if a client has 3 different emails, the macro sees the same client ID and skips sending to the other two.

Fix 1: Track Unique Client + Email Pairs #

If your original code uses a Collection or Dictionary to avoid duplicate sends, update it to use a combined key of client ID and email instead of just the client ID. Here's an example:

Problematic Code (Common Version)

Dim clientID As String
Dim sentClients As Collection
Set sentClients = New Collection

For Each cell In Range("A2:A" & lastRow) ' Column A = Client ID
    clientID = cell.Value
    ' Only send if client hasn't been processed before
    On Error Resume Next
    sentClients.Add clientID, Key:=CStr(clientID)
    On Error GoTo 0
    If Err.Number = 0 Then
        ' Sends only to the first email tied to the client
        SendEmail cell.Offset(0, 1).Value ' Column B = Email
    End If
Next cell

Fixed Code

Dim clientEmailKey As String
Dim sentPairs As Collection
Set sentPairs = New Collection

For Each cell In Range("A2:A" & lastRow)
    clientID = cell.Value
    email = cell.Offset(0, 1).Value
    ' Create a unique key for client ID + email
    clientEmailKey = clientID & "|" & email
    
    ' Only send if this specific client+email pair hasn't been processed
    On Error Resume Next
    sentPairs.Add clientEmailKey, Key:=CStr(clientEmailKey)
    On Error GoTo 0
    If Err.Number = 0 Then
        SendEmail email ' Send to this unique email
    End If
Next cell

Fix 2: Use a Nested Dictionary to Group Emails Per Client #

If you're grouping data first before sending, use a nested dictionary to collect all unique emails for each client, then loop through every email in the group to send messages. This is cleaner for larger datasets:

Dim clientDict As Object
Set clientDict = CreateObject("Scripting.Dictionary")

' Step 1: Collect all unique emails per client
For Each cell In Range("A2:A" & lastRow)
    clientID = cell.Value
    email = cell.Offset(0, 1).Value
    
    If Not clientDict.Exists(clientID) Then
        ' Create a sub-dictionary to store unique emails for this client
        Set clientDict(clientID) = CreateObject("Scripting.Dictionary")
    End If
    ' Add the email to the sub-dictionary (automatically ignores duplicates)
    clientDict(clientID)(email) = True
Next cell

' Step 2: Send an email to every unique email per client
For Each clientID In clientDict.Keys
    For Each email In clientDict(clientID).Keys
        ' Insert your email-sending logic here, e.g.:
        SendEmail email, clientID ' Pass client ID if you need it in the email content
    Next email
Next clientID

Quick Checks to Ensure Success #

• Verify your SendEmail function accepts the email address as a parameter and doesn't overwrite it with a previous value.
• If you need to send emails even if the same client+email appears multiple times (uncommon), remove the deduplication logic entirely and send on every row.
• Test with Debug.Print email before sending actual emails to confirm the correct list of recipients.

内容的提问来源于stack exchange，提问作者FrcCorsair