How to using the VBA to send the specific data in excel to the specific person through email

[Ding YY]

I want to sent the email which contain the all the data belonging to each assignee through email. For example, all the information which is belonging to YuYuan Ding (Assignee) will be send to YuYuan Ding (email address is yuyuan Ding) except those record that status is "Closed", and all the information which is belonging to John (Assignee) will be send to John (email address is John), the code below is what I did for this function, it only can sent to the specific person now but I don't know how to filter the data based on each person and add these data into email body.(The email body will add all the information now). The image i have show below is just for testing, the real one have a lot of data. Pls help me if you can solve this problem.
Thanks for advance!

This is the code that I have did:


Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range

Set rng = Nothing


Set rng = Sheets("Sheet2").Range("A1:J1048574").SpecialCells(xlCellTypeVisible)


If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If


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

Sheets("Sheet2").Select

ActiveSheet.Range("$A$1:$J$6").AutoFilter Field:=3, Criteria1:= _
"=In Progress", Operator:=xlOr, Criteria2:="=Resolved"
Columns("G:G").Select
Selection.Copy
Sheets("Sheet4").Select
Columns("A:A").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$A$1048574").RemoveDuplicates Columns:=1, Header:= _
xlYes


Sheets("Sheet4").Select
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If (Cells(cell.Row, "A").Value) <> "" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Please looking for these defects"
.HTMLBody = RangetoHTML(rng)
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell


cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True




End Sub


Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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 xublishsource=", _
"align=left xublishsource=")


'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


This is the excel:
[TABLE="width: 1909"]
<tbody>[TR]
[TD]Claims Dig. Applications[/TD]
[TD]#[/TD]
[TD]Status[/TD]
[TD]Priority[/TD]
[TD]Subject[/TD]
[TD]Author[/TD]
[TD]Assignee[/TD]
[TD]Due date[/TD]
[TD]Deployment Date[/TD]
[TD]Description[/TD]
[/TR]
[TR]
[TD]Elixir[/TD]
[TD="align: right"]5153[/TD]
[TD]Resolved[/TD]
[TD]High[/TD]
[TD]Elixir[/TD]
[TD]Wenzheng Yeo[/TD]
[TD]YuYuan Ding[/TD]
[TD="align: right"]6/4/2015[/TD]
[TD][/TD]
[TD]Hi Samadhan, I have went through the 4 cases and all the CDT letter was printed before 27/05/2015 but they are still in the list[/TD]
[/TR]
[TR]
[TD]Elixir[/TD]
[TD="align: right"]5079[/TD]
[TD]Closed[/TD]
[TD]High[/TD]
[TD]Elixir[/TD]
[TD]Kwong Chi Tan[/TD]
[TD]YuYuan Ding[/TD]
[TD][/TD]
[TD][/TD]
[TD]For SPA to create claim in Elixir, from workbench, SPA login to elixir using claim assessor's user id. There is a limit to the number of concurrent login from the same user id. Hence, when Elixir failed in login out the specific user id, subsequent login may fail and thus unable to create claim from SPA.[/TD]
[/TR]
[TR]
[TD]SPA[/TD]
[TD="align: right"]4869[/TD]
[TD]Resolved[/TD]
[TD]Normal[/TD]
[TD]SPA[/TD]
[TD]Karthikeyan Subramanian[/TD]
[TD]YuYuan Ding[/TD]
[TD="align: right"]6/3/2015[/TD]
[TD][/TD]
[TD][commissioning] Searching of Surgical Code[/TD]
[/TR]
[TR]
[TD]Elixir[/TD]
[TD="align: right"]4422[/TD]
[TD]Closed[/TD]
[TD]High[/TD]
[TD]Elixir[/TD]
[TD]Wenzheng Yeo[/TD]
[TD]YuYuan Ding[/TD]
[TD][/TD]
[TD="align: right"]6/5/2015[/TD]
[TD]When selecting the restructured hospital provider code in CLAIMS ASSESSMENT, system fetch the non-panel benefit code instead of panel


[/TD]
[/TR]
[TR]
[TD]SPA[/TD]
[TD="align: right"]4869[/TD]
[TD]Resolved[/TD]
[TD]Normal[/TD]
[TD]SPA[/TD]
[TD]Karthikeyan Subramanian[/TD]
[TD]John[/TD]
[TD="align: right"]6/3/2015[/TD]
[TD][/TD]
[TD][commissioning] Searching of Surgical Code[/TD]
[/TR]
</tbody>[/TABLE]