发送单个电子邮件给多个邮件的收件人
我有一个macros，我写了一个用户在列1中放入一个数字列表的macros，然后他们按下一个button，打开一个表单，让他们为Outlook电子邮件select各种参数，包括电子邮件应该发送给谁。 然后在电子邮件中发送这个数字列表。
我想改变macros，所以用户把列表中的数字列1，并在第2列他们把收件人。 然后用相应的号码向每个收件人发送一封电子邮件。
为列中的每个号码创build一个新的电子邮件很容易，但可能有多个电子邮件发送到同一个收件人，这将不被很好地接收。 这也是非常低效的。
我想让我的macros组成员打算给同一个人的号码，然后每个不同的收件人发送一封电子邮件。
示例数据：
1 RecipientA 2 RecipientB 3 RecipientA 4 RecipientC 5 RecipientA 我想发一个电子邮件给收件人A 1/3/5，B 2，C 4。
我不一定需要实际的代码帮助，我只是想不出一个办法来做到这一点。
任何人都可以提出解决scheme吗？
使用Dictionary – 一种方法将：
- 迭代收件人列
- 为新的收件人添encryption钥和值
- 对于现有的收件人将该值附加到现有列表
对于电子邮件部分：
- 迭代字典
- 用每个收件人的ID列表发送一封邮件
代码示例：
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
你可以使用像这样的字典：
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