Results 1 to 3 of 3

Thread: Group and email rows to people

  1. #1
    Acolyte Adnandos's Avatar
    Join Date
    Jun 2018
    Excel Version

    Group and email rows to people

    Register for a FREE account, and/
    or Log in to avoid these ads!

    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
    Tecumseh, OK
    Excel Version
    Add an Exit Sub after .Display to test on one filtered name. Once it works, remove .Display and uncomment .Send.

    '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
      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. _
          .HTMLBody = sBody
        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
    ' 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
      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
    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
        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
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            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, _
            .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
        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

  3. #3
    Neophyte Madjry's Avatar
    Join Date
    Apr 2020
    Excel Version

    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

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