向多个邮件的收件人发送单个电子邮件

Question

我有一个宏，我写了用户在列1中放入数字列表的一个宏，然后他们按下一个按钮并打开一个窗体，让他们为Outlook电子邮件选择各种参数，包括电子邮件应发送给谁。然后它在电子邮件中发送这个数字列表。

我想更改宏，以便用户将列表中的数字放入列1中，并在列2中放入收件人。然后用相应的号码向每个收件人发送一封电子邮件。

为列中的每个号码创建一封新电子邮件很容易，但可能会有多封电子邮件发送给同一收件人，这将不会很好收到。这也会非常低效。

我想让我的宏组成员要去同一个人的号码，然后每个不同的收件人发送一封电子邮件。

示例数据：

1  RecipientA 
2  RecipientB 
3  RecipientA 
4  RecipientC 
5  RecipientA 

我想发送电子邮件至收件人与1/3/5，B 2，C与4

我不一定需要帮助实际的代码，我只是想不出一种方法来做到这一点。

任何人都可以提出解决方案吗？

Answer 1

使用Dictionary - 一种方法是到：

• 迭代的收件人栏
• 新添加收件人为现有收件人键和值
• 价值附加到现有列表

对于电子邮件部分：

• 遍历字典
• 每个收件人发送一个邮件与IDS
名单

代码示例：

Option Explicit 

Sub GetInfo() 

    Dim ws As Worksheet 
    Dim rngData As Range 
    Dim rngCell As Range 
    Dim dic As Object 
    Dim varKey As Variant 

    'source data 
    Set ws = ThisWorkbook.Worksheets("Sheet3") 
    Set rngData = ws.Range("A1:B5") '<~~~ adjust for your range 

    'create dictionary 
    Set dic = CreateObject("Scripting.Dictionary") 

    'iterate recipient column in range 
    For Each rngCell In rngData.Columns(2).Cells 
     If dic.Exists(rngCell.Value) Then 
      dic(rngCell.Value) = dic(rngCell.Value) & "," & rngCell.Offset(0, -1).Value 
     Else 
      dic.Add rngCell.Value, CStr(rngCell.Offset(0, -1).Value) 
     End If 
    Next rngCell 

    'check dictionary values <~~~ you could do the e-mailing here... 
    For Each varKey In dic.Keys 
     Debug.Print dic(CStr(varKey)) 
    Next 

End Sub 

输出与样本数据：

RecipientA : 1,3,5 
RecipientB : 2 
RecipientC : 4 

Answer 2

你可以使用像这样的词典：

Sub test_WillC() 
Dim DicT As Object 
'''Create a dictionary 
Set DicT = CreateObject("Scripting.Dictionary") 

Dim LastRow As Double 
Dim i As Double 

With ThisWorkbook.Sheets("Sheet1") 
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row 
    For i = 2 To LastRow 
     '''Syntax : DicT.Exists(Key) 
     If DicT.Exists(.Cells(i, 2)) Then 
      '''If the key (mail) exists, add the value 
      DicT(.Cells(i, 2)) = DicT(.Cells(i, 2)) & "/" & .Cells(i, 1) 
     Else 
      '''If the key doesn't exist create a new entry 
      '''Syntax : DicT.Add Key, Value 
      DicT.Add .Cells(i, 2), .Cells(i, 1) 
     End If 
    Next i 
End With 'ThisWorkbook.Sheets("Sheet1") 

'''Loop on your dictionary to send your mails 
For i = 0 To DicT.Count - 1 
    YourSubNameToSendMails DicT.Keys(i), DicT.Items(i) 
Next i 

Set DicT = Nothing 
End Sub