向多個郵件的收件人發送單個電子郵件

我有一個宏，我寫了用戶在列1中放入數字列表的一個宏，然後他們按下一個按鈕並打開一個窗體，讓他們爲Outlook電子郵件選擇各種參數，包括電子郵件應發送給誰。然後它在電子郵件中發送這個數字列表。向多個郵件的收件人發送單個電子郵件

我想更改宏，以便用戶將列表中的數字放入列1中，並在列2中放入收件人。然後用相應的號碼向每個收件人發送一封電子郵件。

爲列中的每個號碼創建一封新電子郵件很容易，但可能會有多封電子郵件發送給同一收件人，這將不會很好收到。這也會非常低效。

我想讓我的宏組成員要去同一個人的號碼，然後每個不同的收件人發送一封電子郵件。

示例數據：

1  RecipientA 
2  RecipientB 
3  RecipientA 
4  RecipientC 
5  RecipientA

我想發送電子郵件至收件人與1/3/5，B 2，C與4

我不一定需要幫助實際的代碼，我只是想不出一種方法來做到這一點。

任何人都可以提出解決方案嗎？

來源

2017-03-08 Will C

使用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

來源

2017-03-08 09:46:10

感謝您的羅賓。聽起來像使用字典是要走的路。我以前從未使用過，因此可能需要進行一些研究才能應用它，但這是一個很好的起點。 –

你可以使用像這樣的詞典：

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

來源

2017-03-08 09:48:02 R3uK

謝謝你。想用字典是要走的路。 –

向多個郵件的收件人發送單個電子郵件

回答

相關問題