Sending mails to specific recipients based on a cells value

Yolandi

New Member
Joined
May 26, 2016
Messages
30
Good morning,

I am trying to get excel to send out an email to different sales reps.
So if row X is an error code of "999" then excel needs to send an email to the rep (I placed the email addresses in row K as it differs for every line), but if row X is "0" excel should not send an email.
is this possible? and what formula should i use?
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30
Here is a solution that will aggregate common Sales Rep to one email.

VBA Code:
Sub Email_filter_Bulk2()
'This code writes to Range BB and then deletes that data
'It creates new worksheets that are then deleted As well

Application.ScreenUpdating = False
Dim x As Range
Dim Rng As Range
Dim last  As Long
Dim sht As String

'specify sheet name in which the data is stored
sht = "Sheet1"

last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Sheets(sht).Range("A1:Z" & last)
Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True

    For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
            With Rng
                .AutoFilter
                .AutoFilter field:=1, Criteria1:=x.Value
                        .SpecialCells(xlCellTypeVisible).Copy
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = x.Value
                        ActiveSheet.Paste

                        Columns("Y:Z").EntireColumn.Hidden = True
                            'Call code below
                            Send_newemail4
                        Columns("Y:Z").EntireColumn.Hidden = False
                '       Code Removes new sheet that was created
                        Application.DisplayAlerts = False
                            Sheets(x.Text).Delete
                        Application.DisplayAlerts = True
            End With
    Next x

    ' Turn off filter
    With Sheets(sht)
        Rng.AutoFilter
    End With
    ' Remove data from column BB
    Range([BB2], Cells(Rows.Count, "BB").End(xlUp)) = ""
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With

End Sub

Sub Send_newemail4()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Rng As Range
    Dim lr, a, b, y As Integer
    Dim Signature As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
  
    Set Rng = Nothing
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
    With OutMail
        .Display
    End With
    Signature = OutMail.HTMLBody
   
    With OutMail
        .To = Range("Z2").Value
        .CC = "" 'Range("AA2").Value
        .Subject = "SOH with no Sales"
        .HTMLBody = "Good day, " & Chr(11) & Chr(11) & "Please see SOH with no sales on the below line:" & Chr(11) & Chr(11) & RangetoHTML(Rng) & Chr(11) & Chr(11) & "Kind Regards," & Chr(11) & Chr(11) & "Yolandi van den Berg." & Chr(11) & Chr(11) & Signature
        '.Attachments.Add Range("E2").Value  '("") For attachments
        .Display ' Place apostrophe in front of .display to stop drafts being made
        '.Send ' Remove apostrophe to automatically send the email
   End With
   Set OutMail = Nothing
   Set OutApp = Nothing
   
End Sub

Function RangetoHTML(Rng As Range)
'
    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
hi, is there a way to send the bulk email without creating a new tab for each sales rep? also the mail pulls through blank
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Are you saying the solution doesn't work now? The creation of tabs happens to aggregate common emails. I am using the first name as a differentiation as that was the only field that had different values in the data you provided. If the email is blank it may be because there is a blank first name.

Change this line

VBA Code:
Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True

to this

VBA Code:
Sheets(sht).Range("Z1:Z" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True

to start using the email address as the differentiator.
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30
hi, thank you that works, but its only pulling the header and not the lines as well?
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30
Good day,

just a question, is there a way to alter the Marco to send one email per rep?
so it will mass send all lines that are the same rep and send it to that rep in one mail
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30

ADVERTISEMENT

Hi,

please ignore previous message, so I am using your codes, but its not pulling the email address through?

I have made another tab with the email address as well, is there a way to pull it from there?
 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
The code is written to pull the email from column Z. Moving the email to another sheet will require a rewrite of the code.
 

Watch MrExcel Video

Forum statistics

Threads
1,113,883
Messages
5,544,864
Members
410,640
Latest member
mopey12345
Top