Excel 向包含多条消息的收件人发送一封电子邮件
我写了一个宏,用户将数字列表放入第1列,然后按下按钮,打开一个表单,让他们为outlook电子邮件选择各种参数,包括电子邮件应该发送给谁。然后,它会在电子邮件中发送此号码列表 我想更改宏,以便用户将数字列表放在第1列,并将收件人放在第2列。然后向每个收件人发送一封带有相应号码的电子邮件 为列中的每个数字创建一封新的电子邮件是很容易的,但是可能会有多封电子邮件发送给同一个收件人,这不会很好地收到。这也将是非常低效的 我想让我的宏组将要发送给同一个人的号码组合起来,然后为每个不同的收件人发送一封电子邮件 示例数据:Excel 向包含多条消息的收件人发送一封电子邮件,excel,vba,outlook,Excel,Vba,Outlook,我写了一个宏,用户将数字列表放入第1列,然后按下按钮,打开一个表单,让他们为outlook电子邮件选择各种参数,包括电子邮件应该发送给谁。然后,它会在电子邮件中发送此号码列表 我想更改宏,以便用户将数字列表放在第1列,并将收件人放在第2列。然后向每个收件人发送一封带有相应号码的电子邮件 为列中的每个数字创建一封新的电子邮件是很容易的,但是可能会有多封电子邮件发送给同一个收件人,这不会很好地收到。这也将是非常低效的 我想让我的宏组将要发送给同一个人的号码组合起来,然后为每个不同的收件人发送一封电子
1 RecipientA
2 RecipientB
3 RecipientA
4 RecipientC
5 RecipientA
RecipientA : 1,3,5
RecipientB : 2
RecipientC : 4
我想用1/3/5向收件人A发送电子邮件,用2向收件人B发送电子邮件,用4向收件人C发送电子邮件
我不一定需要实际代码的帮助,我只是想不出一种方法来做到这一点
有人能提出解决方案吗?使用
字典
-一种方法是:
- 迭代收件人列
- 对于新收件人,请添加键和值
- 对于现有收件人,将该值附加到现有列表中
- 反复阅读字典
- 使用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
您可以使用这样的词典:
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
谢谢你,罗宾。听起来使用字典是一个不错的选择。我以前从未使用过这个,所以可能需要做一些研究来应用它,但这是一个很好的起点。谢谢你。我认为使用字典是一种方法。