Macro to filter and copy table and send mails in outlook

[Sreeja]

Hi All,
I am trying to create a macro for filtering column A from an excel file and copying the filtered table in Outlook body and sending mails to all people in column A (until the mail is sent o last person). So far i was able to get a code to do this. But i am facing the below challenges.
1) I need to cc the people in column B and C . This should be based on the filtered value. That is all the names corresponding to the filtered values alone should appear in CC.
2) If there are duplicates in column B or in case of column C that should be eliminated. That is if the name "person A" appears twice in column B it should be ccd only once.
3) There are blanks in between column C. That is not all cells in column C have values.

Below is the macro that i have so far. Please help is adding the above points into this. i have added the format of sample mail as image to get a better understanding.

Sub Test()
Dim dic, rng, cel, k
Set rng = Sheets("Sheet1").UsedRange.Offset(1)
Set dic = CreateObject("Scripting.Dictionary")


For Each cel In rng.Columns(1).Cells
If Not dic.exists(cel.Value) Then dic.Add cel.Value, cel.Value
Next
With ActiveSheet
For Each k In dic.keys
.Columns("A:H").AutoFilter
.Range("A:H").AutoFilter Field:=1, Criteria1:=k
Call Mail_Sheet_Outlook_Body(dic(k))
Next k
End With
End Sub



Sub Mail_Sheet_Outlook_Body(addr)

Dim rng As Range

Dim OutApp As Object

Dim OutMail As Object

Dim deptName As Variant



With Application

.EnableEvents = False

.ScreenUpdating = False

End With



deptName = Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeVisible).End(xlDown).Value



Set rng = Nothing

Set rng = ActiveSheet.UsedRange



Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)



On Error Resume Next

With OutMail

.To = addr

.CC =

.SentOnBehalfOfName =

.BCC = ""

.Subject = "Pending action reminder"

.HTMLBody = "Dear team" & vbVerticalTab & vbVerticalTab & “blah blab blah “ &RangetoHTML(rng)

.Display

End With

On Error GoTo 0





With Application

.EnableEvents = True

.ScreenUpdating = True

End With





Set OutMail = Nothing

Set OutApp = Nothing

End Sub









Function RangetoHTML(rng As Range)



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"







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