'Add reference: Microsoft Outlook xx.x Library, where xx.x is 14.0, 15.0, 16.0, etc.
Sub OutlookFilterRun()
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Dim a() As Variant, b As Variant, r As Range, c As Range, i As Long
Dim sBody As String
'Get unique and non-blank values in col G.
a() = RangeTo1dArray(Range("G2", Cells(Rows.Count, "G").End(xlUp)))
b = UniqueArrayByDict(a(), tfStripBlanks:=True)
'Add an AutoFilter
Range("A1").AutoFilter
Set olApp = New Outlook.Application
For i = 0 To UBound(b)
'Filter for each unique col G value.
Set c = ActiveSheet.UsedRange.CurrentRegion
c.AutoFilter 7, b(i)
Set c = Intersect(c, Columns("L:L").SpecialCells(xlCellTypeVisible))
Set c = c.End(xlDown)
Debug.Print c.Address
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = c.Value
.Subject = "Please Review"
sBody = "Hello, please review your sales details." & vbCrLf & vbCrLf
sBody = sBody & RangetoHTML(ActiveSheet.UsedRange.CurrentRegion. _
SpecialCells(xlCellTypeVisible))
.HTMLBody = sBody
.Display
'.Send
End With
Next i
'ActiveSheet.ShowAllData 'One way to turn off filters.
Range("A1").AutoFilter 'Turn off autofilter
Set olMail = Nothing
Set olApp = Nothing
End Sub
Function RangeTo1dArray(aRange As Range) As Variant
Dim a() As Variant, c As Range, i As Long
ReDim a(0 To aRange.Cells.Count - 1)
i = i - 1
For Each c In aRange
i = i + 1
a(i) = c
Next c
RangeTo1dArray = a()
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, _
Optional tfStripBlanks = False) 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
If tfStripBlanks And e <> "" Then dic.Add e, Nothing
End If
Next e
UniqueArrayByDict = dic.Keys
End Function
'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