CODEWITHSUNDEEP
excelvbaoutlook
WSC
WSC

Reputation: 993

Send single email to recipients with multiple messages

I have a macro I wrote where users put a list of numbers into column 1, and they press a button and a form opens which lets them select a variety of parameters for the outlook email, including who the email should be sent to. It then sends this list of numbers in the email.

I want to change the macro so the user puts the list of numbers in column 1, and in column 2 they put the recipients. Then a single email is sent to each recipient with the corresponding numbers.

It would be easy to create a new email for each number in the column, but there might be multiple emails going to the same recipient, which would not be well received. It would also be very inefficient.

I want to have my macro group up the numbers who are going to the same person, then send one email per different recipient.

Example data:

1      RecipientA
2      RecipientB
3      RecipientA
4      RecipientC
5      RecipientA

I want to send an email to recipient A with 1/3/5, B with 2, C with 4.

I don't necessarily need help with the actual code, I just can't think of a way to do this.

Can anyone suggestion a solution?

Upvotes: 1

Views: 780

Answers (2)

R3uK
R3uK

Reputation: 14537

You could use a Dictionary like this :

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

Upvotes: 1

Robin Mackenzie
Robin Mackenzie

Reputation: 19319

Use a Dictionary - one method would to:

  • iterate recipient column
  • for a new recipient add the key and value
  • for an existing recipient append the value to the existing list

For the e-mailing part:

  • iterate the dictionary
  • send a single mail per recipient with the list of ids

Code sample:

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

Output with your sample data:

RecipientA : 1,3,5
RecipientB : 2
RecipientC : 4

Upvotes: 1

Related Questions