Results 1 to 2 of 2

Thread: Group and email rows to people

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Acolyte Adnandos's Avatar
    Join Date
    Jun 2018
    Posts
    25
    Articles
    0
    Excel Version
    365

    Group and email rows to people

    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.Email rows to people.xlsx

  2. #2
    Conjurer Kenneth Hobson's Avatar
    Join Date
    Mar 2014
    Location
    Tecumseh, OK
    Posts
    136
    Articles
    0
    Excel Version
    365
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •