Help on filtering an excel based Column C and send email for every filtered item

[csaras84]

Hi Folks,

I have an excel with raw data (Autolink) of many columns. I have a code on another workbook which has a command button which when clicked invokes a code to add Sheet1 to the raw data workbook (Autolink), that includes only certain columns but also adds a new column where number of days are calculated based on a dates in other columns.

I have implemented the above but now what I want to do is this and finding it a tad bit difficult being a beginner.

1. Sheet1 needs to be filtered based on Column C (which includes Owner IDs).
2. For every owner ID, the selected range needs to be emailed to ownerID appended by the domain.
3. The range must be copied to the email body and not attached as an excel.

Can someone please help me on this?

Thank you in advance.


Saras

[mdmackillop]

Give this a try. You'll need to incorporate email addresses to suit.

Option Explicit


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(3).Cells
If Not dic.exists(cel.Value) Then dic.Add cel.Value, cel.Value & "@email.com"
Next
With ActiveSheet
For Each k In dic.keys
.Columns("A:G").AutoFilter
.Range("A:G").AutoFilter Field:=3, Criteria1:=k
Call Mail_Sheet_Outlook_Body(dic(k))
Next k
End With
End Sub


Sub Mail_Sheet_Outlook_Body(addr)
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

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


Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = addr
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = 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)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 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

[Kenneth Hobs]

This is somewhat similar to#2.

Set the references in Tools > References, for Microsoft Scripting Runtime and Outlook as detailed in the comments. Change the suffice for column C email addresses in the To fields and other Outlook fields to suit. It creates and uses a scratch worksheet for the filtered data and deletes it.

Paste code to a Module:

Sub Main()
Dim ws As Worksheet, sws As Worksheet, a(), e
'Add reference: Microsoft Outlook xx.x Library, where xx.x is 14.0, 15.0, 16.0, etc.
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Set olApp = New Outlook.Application

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

'Worksheet to filter and email
Set ws = Worksheets("Sheet1")
'Create and set a temporary scratch worksheet
Set sws = Worksheets.Add(after:=Worksheets(Worksheets.Count))

'Make unique array of values in column C.
With ws
a() = .Range("C2", .Cells(Rows.Count, "C").End(xlUp)).Value
a = UniqueArrayByDict(a())
'Turn on autofilter
.Range("A1").AutoFilter
End With

'Filter and Email each set of data.
For Each e In a()
ws.Range("A1:G8").AutoFilter Field:=3, Criteria1:=e
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = e & ".gmail.com"
.Subject = "Case Report Dated: " & Format(Date, "mm/dd/yyyy")
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy
sws.Range("A1").PasteSpecial xlPasteAll
.HTMLBody = RangetoHTML(sws.UsedRange)
sws.UsedRange.Clear
'.Display
.Send
End With
Next e

'Cleanup
'Turn off autofilter
ws.Range("A1").AutoFilter
sws.Delete
Set olMail = Nothing
Set olApp = Nothing
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub


'http://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 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




' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
'Dim dic As Object 'Late Binding method - Requires no Reference
'Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
Dim dic As Dictionary 'Early Binding method
Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End Function

[csaras84]

mdmackillop Thank you so much! This works like a charm.

Is it possible to add any additional text like addressing the user in the email body and an email Signature as well?

Kenneth Hobs, thank you for the second code as well. I'm using the first one by mdmackillop for now.


Saras

[Kenneth Hobs]

Use string concatenation to add to your body. Same thing is done for signature. See Ron's example: http://www.rondebruin.nl/win/s1/outlook/signature.htm

[csaras84]

Thanks again. That worked as well.

[csaras84]

The filter has a value of 'None' which is also added while emailing and this email bounces. I also have an empy null email going - like - ' at (I'm unable to insert the 'at' character here)email.com' with no table. Can this be avoided. Thank you.

[Kenneth Hobs]

There are several ways to handle that.

You can add another filter criterion. Manually record a macro to see the syntax. An Advanced Filter can be used for more than two criterion for one field/column.

Another approach that might be easier would be ANDs for the IF for the dic.Add. Similarly, one would use an IF inside the loop for my For Each e in a(). For the former:

'If Not dic.exists(cel.Value) Then dic.Add cel.Value, cel.Value & "@email.com"
If Not dic.Exists(cel.Value) And cel.Value <> "" And _
cel.Value <> "None" Then dic.Add cel.Value, cel.Value & "@email.com"

[csaras84]

Thank you so much!