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

test

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