向包含多封邮件的收件人发送一封电子邮件-解网

问：

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

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

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

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

示例数据：

1      RecipientA
2      RecipientB
3      RecipientA
4      RecipientC
5      RecipientA

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

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

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

Excel VBA 展望

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

向包含多封邮件的收件人发送一封电子邮件

Send single email to recipients with multiple messages

评论

评论

评论