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

Ding YY

New Member
Jun 10, 2015
Hi all, 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 excel data which is belonging to John (Assignee) will be send to John (email address is John) except those record that status is "Closed", 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 assignee 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


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

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)
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

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
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
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
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, _
.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
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

This is the sample of excel:
Claims Dig. Applications#StatusPrioritySubjectAuthorAssigneeDue dateDeployment DateDescription
Elixir5153ResolvedHighElixirWenzheng YeoYuYuan Ding6/4/2015Hi 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
Elixir5079ClosedHighElixirKwong Chi TanYuYuan DingFor 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.
SPA4869ResolvedNormalSPAKarthikeyan SubramanianYuYuan Ding6/3/2015[commissioning] Searching of Surgical Code
Elixir4422ClosedHighElixirWenzheng YeoYuYuan Ding6/5/2015When selecting the restructured hospital provider code in CLAIMS ASSESSMENT, system fetch the non-panel benefit code instead of panel
SPA4869ResolvedNormalSPAKarthikeyan SubramanianJohn6/3/2015[commissioning] Searching of Surgical Code


Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back