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?
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
Use this VBA code

VBA Code:
Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "K").End(xlUp).Row
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        If Sheet1.Cells(i, "X").Value = "999" Then
            With OutMail
                .To = Sheet1.Cells(i, "B").Value
                .CC = ""
                .Subject = "Enter Subject here" '& Sheet1.Cells(i, "B")
                .HTMLBody = "Dear " & Cells(i, "A") & "," & Chr(11) & Chr(11) & "Enter Body here" & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
                '.Attachments.Add
                .Display    'DELETE THIS LINE IF USING SEND
                '.send
            End With
            Set OutMail = Nothing
            Set OutApp = Nothing
        End If
    Next i

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30
hi,

so how i need the email to look is:
Good day,

please see SOH with no Sales:
(then it need =s to give the heading and the line with the 999)
Sales RepSiteStore NameVendorVendor NameArticleArticle DescClassOrder UnitUOM06-202007-202008-202009-202010-202011-202011-2019Curr Y/SSOHSOOSITPR QtyAct DSCLast RecvLast Sold
LorenzoM06Ottery10387SGX SALES (PTY) LTD379572001NANDOS PERI PERI SAUCE 500G, HOTNEW6EA02430120042253000099928.08.202013.09.2020

thank you kindly,
Yolandi


(Below is an example of my spreadsheet)
Sales RepSiteStore NameVendorVendor NameArticleArticle DescClassOrder UnitUOM06-202007-202008-202009-202010-202011-202011-2019Curr Y/SSOHSOOSITPR QtyAct DSCLast RecvLast SoldSend Email ToCCSubjectBodySend Email
LorenzoM06Ottery10387SGX SALES (PTY) LTD379572001NANDOS PERI PERI SAUCE 500G, HOTNEW6EA02430120042253000099928.08.202013.09.2020yolandivdberg@gmail.comyolandivdberg@gmail.comSOH with no SalesGood day, %0APlease see SOH with no sales on the below line:%0AKind Regards,%0AYolandi van den Berg.Send email
 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hello, this Is VBA code. You can attach it to your excel workbook by selecting F11, entering this code in the module that shows up, then selecting F5 to run the code. Let us know if you have questions.

VBA Code:
Sub email()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i, lr As Long
    Dim Path, Signature As String
    Dim Rng As Range
    Dim rng1 As Range
    

    Application.ScreenUpdating = False
    
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "K").End(xlUp).Row
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .Display
        End With
        Signature = OutMail.HTMLBody

        If Sheet1.Cells(i, "W").Value = "999" Then
        Set rng1 = Range("A1:Y1")
        Set Rng = Range("A" & i & ":Y" & i)
            With OutMail
                .To = Sheet1.Cells(i, "Z").Value
                .CC = ""
                .Subject = "SOH with no Sales" ' Sheet1.Cells(i, "B")
                .HTMLBody = "Good day, " & Chr(11) & Chr(11) & "Please see SOH with no sales on the below line:" & Chr(11) & Chr(11) & RangetoHTML(rng1) & RangetoHTML(Rng) & Chr(11) & Chr(11) & "Kind Regards," & Chr(11) & Chr(11) & "Yolandi van den Berg." & Chr(11) & Chr(11) & Signature
                '.Attachments.Add
                .Display    'DELETE THIS LINE IF USING SEND
                '.send
            End With
            Set OutMail = Nothing
            Set OutApp = Nothing
        End If
    Next i

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
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
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30


Private Sub Send_999_emails()
'
' Macro to populate and send emails, based on an error code cell (and associated cells)
'

Dim objOutl As Object, objMess As Object
Dim rng As Range

'Dim n As Integer '### change this

On Error Resume Next
'Application.ScreenUpdating = False

Set rng = Nothing

m = MsgBox("Click Yes to confirm that you want Outlook to send error code 999 emails", vbYesNo, "Ready?")
If m = 7 Then
MsgBox "Try later when you're ready. Closing macro"
Exit Sub
End If

Set objOutl = CreateObject("Outlook.Application") 'Grab Outlook
'jOutl.Visible = True

'MsgBox objOutl.Session.CurrentUser.Name ' Identify Outlook user
If Sheet1.Cells(3, 23) = 999 Then

Set rng = Sheet1.Range("A1:y1, A3:y3").SpecialCells(xlCellTypeVisible)

Set objMess = objOutl.CreateItem(olMailItem) '
With objMess
.To = Sheet1.Cells(3, 26)
.cc = Sheet1.Cells(3, 27)
.Subject = "SOH with no Sales: "
.HTMLBody = "Good day," & "<br>" & "Please see SOH with no sales on the below line:" & "<br>" & RangetoHTML(rng) & "<br>" & "<br>" & "Kind Regards," & "<br>" & "Yolandi van den Berg"
'.body = Sheet1.Cells(3, 29) '### change this '"Hi" '& Chr(13) & Chr(13
.Display
'.Save
'.send
End With

Else:

End If

'Application.ScreenUpdating = True


MsgBox "Created email <" & "SOH with no Sales: " & Sheet1.Cells(3, 7) & "> and sent to " & Sheet1.Cells(3, 26) '### change this

Set objMess = Nothing

End Sub

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



Private Sub Cb_Send999_Click()
'
' Macro to populate and send emails, based on an error code cell (and associated cells)
'

Dim objOutl As Object, objMess As Object
Dim rng As Range

'Dim n As Integer '### change this

On Error Resume Next
'Application.ScreenUpdating = False

Set rng = Nothing

m = MsgBox("Click Yes to confirm that you want Outlook to send error code 999 emails", vbYesNo, "Ready?")
If m = 7 Then
MsgBox "Try later when you're ready. Closing macro"
Exit Sub
End If

Set objOutl = CreateObject("Outlook.Application") 'Grab Outlook
'jOutl.Visible = True

'MsgBox objOutl.Session.CurrentUser.Name ' Identify Outlook user
If Sheet1.Cells(3, 23) = 999 Then

Set rng = Sheet1.Range("A1:y1, A3:y3").SpecialCells(xlCellTypeVisible)

Set objMess = objOutl.CreateItem(olMailItem) '
With objMess
.To = Sheet1.Cells(3, 26) '### change this
.cc = "juan@effectivesales.co.za"
.Subject = "SOH with No Sales:"
.HTMLBody = "Good day" & "<br>" & "Please advise on the below line:" & "<br>" & RangetoHTML(rng) & "<br>" & "Please feel free to contact me should you have any queries." & "<br>" & "Thank you kindly," & "<br>" & "Kind Regards," & "<br>" & "Yolandi van den Berg"
.Display

End With

Else:

End If

'Application.ScreenUpdating = True


MsgBox "Created email <" & "SOH with no Sales: " & Sheet1.Cells(3, 7) & "> and sent to " & Sheet1.Cells(3, 26) '### change this

Set objMess = Nothing

End Sub


Hi,
so I am using this code, but I am struggling to extend the cell range to the entire work sheet and not just row 3,

this is an example of my sheet:
Sales RepSiteStore NameVendorVendor NameArticleArticle DescClassOrder UnitUOM06-202007-202008-202009-202010-202011-202011-2019Curr Y/SSOHSOOSITPR QtyAct DSCLast RecvLast SoldSend Email To
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA303310455652999621100099927.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996212000100027.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA303310455652999621300099927.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996214000100227.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996215000100327.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA303310455652999621600099927.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996217000100527.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996218000100627.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996219000100727.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA3033104556529996211000099927.10.202010.11.2020yolandivdber@gmail.com
SisonkeM09Centurion9777CREDE OILS (PTY) LTD312976LEMCKE COCONUT OIL 1LTNEW12EA30331045565299962111000100927.10.202010.11.2020yolandivdber@gmail.com

I need the code to run through all the rows and send out an email to all rows with 999's
 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Try the recommended code.
 

Yolandi

New Member
Joined
May 26, 2016
Messages
30
hi, sorry did not see your pervious reply, thank you it works perfectly :)
 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
50
Office Version
  1. 365
Platform
  1. Windows
The code is written to send only for the 999 condition. What other emails are being sent falsely?
 

Watch MrExcel Video

Forum statistics

Threads
1,114,207
Messages
5,546,546
Members
410,745
Latest member
citrictango
Top