Send Excel Table in Mail body based on Filtered data and corresponding email in a separate sheet|VBA & Macros|Excel Forum|My Online Training Hub

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

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

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