Group and email rows to people

Adnandos

New member
Joined
Jun 12, 2018
Messages
25
Reaction score
0
Points
0
Excel Version(s)
365
Hi all.

I have an excel workbook that goes into the thousands of rows.

It tracks sales by sales agent. Currently I am filtering the rows by agent, copying and pasting their sales into an email that gets sent to each and every agent.

Is there a way to have a macro/VBA send one email to each agent with a listing of the sales they have done?

I have attached a sample workbook.

Agents are emailed all the columns.View attachment Email rows to people.xlsx
 
Add an Exit Sub after .Display to test on one filtered name. Once it works, remove .Display and uncomment .Send.

Code:
'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
 
Keeping excel formating in email body

The email created does not keep the formatting from Excel.
I know you can add HTML code to keep the formatting in the email body.

How can I modify the code to apply HTML ?

Thank you
 
Back
Top