Question

我有一个我写过的宏，用户将一个数字列表放入第1列，然后按下一个按钮，打开一个表单，让他们为outlook电子邮件选择各种参数，包括将电子邮件发送给谁。然后它会在电子邮件中发送这个号码列表。

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

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

我希望我的宏组能够找到去同一个人的号码，然后每个不同的收件人发送一封电子邮件。

示例数据：

1      RecipientA
2      RecipientB
3      RecipientA
4      RecipientC
5      RecipientA

我想向收件人A发送一封电子邮件，收件人为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

向具有多条消息的收件人发送单个电子邮件

2 个答案: