One mail per recipient

  • I'm trying to find a code that can send a mail from Excel, but where there theres is only 1 mail per recipient - even if their e-mail adress are severel times in the rows data. An exampel could look like this:

    E-mail Result

    [email protected] 1

    [email protected] 2

    [email protected] 2

    [email protected] 1

    [email protected] 3


    So the recipient with [email protected] adress should only recieve 1 mail with result 1 and 2 in the mails body text.

    The recipient with [email protected] adress should recieve 1 mail with result 2 in the mails body text. etc...


    Hope you can help me

  • Should be doable, but some more info would be helpful for building the exact code. Are you wanting to send a basic message to each user, an image from body of workbook, or an attachment? Is it just the two columns of data we need to work with?


    One way I'd do it is to copy the list of emails to a new blank column, Remove Duplicates. Then cycle through that unique list and use it to filter for emails back in your original data. Depending on what we do next, we either create an attachment to send, or copy and image.

    Best Regards,
    Luke M
    =======
    "A little knowledge is a dangerous thing."

  • No image or attachtment, just body text (the result). The first mails body would be "Result: 1 vbnewline Result: 2". Second mail would be "Result 2"


    This is just an example, but I will develop it further my self if someone kan help me with the above part

  • Thx. It helped me somewhat. How would this code look like if the e-mail adresses were in column AD and the data in the mail were from the columns B, D, E, F, I, J, K, M, and N. Data from column Q, R, and S should also be included if value > 0.


    Sub Send_Row_Or_Rows_2()

    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    'Don't forget to copy the function RangetoHTML in the module.
    'Working in Excel 2000-2016

    Dim OutApp As Object

    Dim OutMail As Object

    Dim rng As Range

    Dim Ash As Worksheet

    Dim Cws As Worksheet

    Dim Rcount As Long

    Dim Rnum As Long

    Dim FilterRange As Range

    Dim FieldNum As Integer

    On Error GoTo cleanup

    Set OutApp = CreateObject("Outlook.Application")

    With Application

    .EnableEvents = False

    .ScreenUpdating = False

    End With

    'Set filter sheet, you can also use Sheets("MySheet")

    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)

    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)

    FieldNum = 2 'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1

    Set Cws = Worksheets.Add

    FilterRange.Columns(FieldNum).AdvancedFilter _

    Action:=xlFilterCopy, _

    CopyToRange:=Cws.Range("A1"), _

    CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell

    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop

    If Rcount >= 2 Then

    For Rnum = 2 To Rcount

    'Filter the FilterRange on the FieldNum column

    FilterRange.AutoFilter Field:=FieldNum, _

    Criteria1:=Cws.Cells(Rnum, 1).Value

    'If the unique value is a mail addres create a mail

    If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

    With Ash.AutoFilter.Range

    On Error Resume Next

    Set rng = .SpecialCells(xlCellTypeVisible)

    On Error GoTo 0

    End With

    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail

    .to = Cws.Cells(Rnum, 1).Value

    .Subject = "Test mail"

    .HTMLBody = RangetoHTML(rng)

    .Display 'Or use Send

    End With

    On Error GoTo 0

    Set OutMail = Nothing

    End If

    'Close AutoFilter

    Ash.AutoFilterMode = False

    Next Rnum

    End If

    cleanup:

    Set OutApp = Nothing

    Application.DisplayAlerts = False

    Cws.Delete

    Application.DisplayAlerts = True

    With Application

    .EnableEvents = True

    .ScreenUpdating = True

    End With

    End Sub

  • Hello,


    Not sure to fully understand your remarks ...


    1. With e-mail addresses in column AD ... you only need to adjust the instruction

    With OutMail

    .to = Cws.Cells(Rnum, 1).Value


    2. Regarding the specific ranges ...the function RangetoHTML is designed exactly for this purpose


    Hope this will help

    If you feel like saying "Thank You" for the help received, do not hesitate to click the "Like" icon ...just below...in the bottom right corner...:)