Macro to filter and copy table and send mails in outlook

Sreeja

New Member
Joined
Apr 4, 2021
Messages
1
Office Version
  1. 2010
Platform
  1. Windows
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 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
 

Attachments

  • sample mail.PNG
    sample mail.PNG
    30.6 KB · Views: 8

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

Watch MrExcel Video

Forum statistics

Threads
1,133,271
Messages
5,657,757
Members
418,411
Latest member
Excellency

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 MrExcel.com.
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 "mrexcel.com".
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
Top