向包含多条消息的收件人发送一封电子邮件答案

【问题标题】：Send single email to recipients with multiple messages向包含多条消息的收件人发送一封电子邮件
【发布时间】：2023-03-11 08:52:02
【问题描述】：

我写了一个宏，其中用户将数字列表放入第 1 列，然后他们按下一个按钮并打开一个表单，让他们为 Outlook 电子邮件选择各种参数，包括应将电子邮件发送给谁.然后它在电子邮件中发送此号码列表。

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

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

我想让我的宏将发送给同一个人的号码分组，然后为每个不同的收件人发送一封电子邮件。

示例数据：

1      RecipientA
2      RecipientB
3      RecipientA
4      RecipientC
5      RecipientA

我想向收件人 A 发送 1/3/5、B 和 2、C 和 4 的电子邮件。

我不一定需要实际代码方面的帮助，我只是想不出办法。

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

【问题讨论】：

标签： excel vba outlook

【解决方案1】：

使用Dictionary - 一种方法可以：

迭代收件人列
为新收件人添加键和值
对于现有收件人，将值附加到现有列表中

对于电子邮件部分：

迭代字典
为每个收件人发送一封带有 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

【讨论】：

感谢这位罗宾。听起来像使用字典是要走的路。我以前从未使用过它，因此可能需要进行一些研究才能应用它，但这是一个很好的起点。

【解决方案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

【讨论】：

谢谢你。认为使用字典是要走的路。