Sub mailKclct()
'https://chandoo.org/forum/threads/vba-to-filter-data-based-on-column-and-copy-to-the-body-of-the-mail.45912/
Dim Wks As Worksheet
Dim OutMail As Object, OutApp As Object
Dim cel As Range, myRng As Range
Dim Itm As Variant
Dim LastRow As Long
Dim Dest As String, strbody As String
Dim collOwner As New Collection
Set Wks = ThisWorkbook.Sheets("Deal Info")
On Error Resume Next
For Each cel In Wks.Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row)
collOwner.Add cel.Value, CStr(cel.Value)
Next
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each Itm In collOwner
Wks.Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=5, Criteria1:=Itm
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set myRng = Wks.Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible)
Dest = Cells(LastRow, "F").Value
strbody = "Dear ," & "<br>" & _
"See the list of deals" & "<br/><br>"
With OutMail
.To = Dest
.CC = ""
.BCC = ""
.Subject = "Deals"
.HTMLBody = strbody & RangetoHTML(myRng)
.Display
'.Send
End With
On Error GoTo 0
Next
On Error Resume Next
Wks.ShowAllData
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(myRng As Range)
Dim TempFile As String
Dim TempWB As Workbook
Dim fso As Object
Dim ts As Object
Dim i As Integer
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
myRng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
For i = 7 To 12
With .UsedRange.Borders(i)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
Next i
End With
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
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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function