Hi, I dn't have Outloo installed to test it so I do not know what errors you get

I did modify this code and maybe it can help you

Public Sub mailK()



Dim Wks As Worksheet
Dim OutMail As Object
Dim OutApp As Object
Dim myRng As Range
Dim list As Object
Dim item As Variant
Dim LastRow As Long
Dim uniquesArray()
Dim Dest As String
Dim strbody
Dim fRange As Range
Set Wks = ThisWorkbook.Sheets("FICO DATA")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

With Wks
For Each item In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

Next
End With

On Error Resume Next
Wks.ShowAllData
Err.Clear
Set fRange = Wks.Range("A1:L" & Range("A" & Rows.Count).End(xlUp).Row)
For Each item In list
Wks.Range("A1:L" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1
Wks.Range("A1:L" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=item

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRng = fRange.SpecialCells(xlCellTypeVisible)
' Set myRng = Wks.Range("A1:L" & LastRow).SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
Dest = WorksheetFunction.VLookup(Range("A2").Value, Worksheets("DSP Emails").Range("B:C"), 2)
strbody = "Guten Morgen DSPs," & vbNewLine & vbNewLine & _
"Anbei die heutige FICO Auswertung." & vbNewLine & vbNewLine & _
"mit freundlichen Grüßen," & vbNewLine & vbNewLine & _
"your ORM TEAM"

With OutMail
.To = Dest
.CC = Worksheets("DSP Emails").Range("C10")
.BCC = ""
.Subject = "FICO Auswertung"
.HTMLBody = strbody & RangetoHTML(myRng)
.Display
'.Send
End With
End If
Err.Clear
Next item

On Error Resume Next
Wks.ShowAllData
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

Thanks for the help but that did not solve my problem of filtering data to a specific in A column.

it has to be filtered and then send the filtered values as a mail body to the designated DSP in A Column

Slightly modified code

Public Sub mailK()

Dim Wks As Worksheet
Dim OutMail As Object
Dim OutApp As Object
Dim myRng As Range
Dim list As Object
Dim item As Range
Dim LastRow As Long
Dim uniquesArray()
Dim Dest As String
Dim strbody
Dim fRange As Range
Dim tbl As ListObject
Set Wks = ThisWorkbook.Sheets("FICO DATA")
Set tbl = Wks.ListObjects("FICOTable")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

With Wks
For Each item In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

Next
End With

On Error Resume Next
Wks.ShowAllData
Err.Clear
Set fRange = tbl.DataBodyRange
For Each item In tbl.ListColumns(1).DataBodyRange
fRange.AutoFilter Field:=1
fRange.AutoFilter Field:=1, Criteria1:=item

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRng = fRange.SpecialCells(xlCellTypeVisible)
' Set myRng = Wks.Range("A1:L" & LastRow).SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
Dest = WorksheetFunction.VLookup(item.Text, Worksheets("DSP Emails").Range("B:C"), 2)
strbody = "Guten Morgen DSPs," & vbNewLine & vbNewLine & _
"Anbei die heutige FICO Auswertung." & vbNewLine & vbNewLine & _
"mit freundlichen Grüßen," & vbNewLine & vbNewLine & _
"your ORM TEAM"

With OutMail
.To = Dest
.CC = Worksheets("DSP Emails").Range("C10")
.BCC = ""
.Subject = "FICO Auswertung"
.HTMLBody = strbody & RangetoHTML(myRng)
.Display
'.Send
End With
End If
Err.Clear
Next item

On Error Resume Next
Wks.ShowAllData
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

I updated the file you attached and have adapted the code a little.

Chandoo's idea is great but when you work with Tables you can use a better approach.

Like I mentioned I do not have Outlook installed but the process seems to work as designed

Happy Easter

PS the second attachment is correct

I would appreciate it if you could find the time to tell us if the solution/option helped you.

Public Sub Geht()

Dim Wks As Worksheet
Dim OutMail As Object
Dim OutApp As Object
Dim myRng As Range
Dim list As Object
Dim item As Range
Dim LastRow As Long
Dim uniquesArray()
Dim Dest As String
Dim strbody
Dim fRange As Range
Dim tbl As ListObject
Set Wks = ThisWorkbook.Sheets("FICO DATA")
Set tbl = Wks.ListObjects("FICOTable")

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

With Wks
For Each item In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))

Next
End With

On Error Resume Next
Wks.ShowAllData
Err.Clear
Set fRange = tbl.DataBodyRange
For Each item In tbl.ListColumns(1).DataBodyRange
fRange.AutoFilter Field:=1
fRange.AutoFilter Field:=1, Criteria1:=item

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Set myRng = fRange.SpecialCells(xlCellTypeVisible)
Set myRng = Sheets("FICO DATA").Range("A1:L4").SpecialCells(xlCellTypeVisible)
' Set myRng = Wks.Range("A1:L" & LastRow).SpecialCells(xlCellTypeVisible)
If Err.Number = 0 Then
Dest = WorksheetFunction.VLookup(item.Text, Worksheets("DSP Emails").Range("B:C"), 2, False)
strbody = "Guten Morgen DSPs," & vbNewLine & vbNewLine & _
"Anbei die heutige FICO Auswertung." & vbNewLine & vbNewLine & _
"mit freundlichen Grüßen," & vbNewLine & vbNewLine & _
"your ORM TEAM"

With OutMail
.To = Dest
.CC = Worksheets("DSP Emails").Range("C10")
.BCC = ""
.Subject = "FICO Auswertung"
.HTMLBody = strbody & RangetoHTML(myRng) & vbNewLine & Signature
.Display
'.Send
End With
End If
Err.Clear
Next item

On Error Resume Next
Wks.ShowAllData
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

That is what i got out with a little modification from my side now every DSP in Row A who is filtered is then send a email based on the email List.

Thank you guys for helping me on this topic!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Your are THE BEST

Good to read.

What's the code for the Signature?

The signature does not work. but i am ok with it 😀