How to send email via Excel when the value of cell is "Yes" - vba

I have an Excel table and a bit of macro. I wanted to automatically send email to a certain person when cell value == to "Yes". Also I want to send the email only if the date is today.
Please see screenshot:
Error Screenshot Sir
Private Sub cmdMove_Click()
'Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("J").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "H").Value) = "Yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ThisWorkbook.ActiveSheet("Server").Range("I3").Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "Ryan").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
End Sub

Try something like the following. Assumes Date is in column A and is an actual Date and that can be compared with what the Date function returns. There is a fair bit of tidying up that could be done on this.
I would take note of #BruceWayne's comment regarding using a Worksheet_Change event. If you can decide which cell(s), or column, determine(s) the triggering of the sub e.g. if column H has a value that changes then test each condition and determine whether to send e-mail, then you can call this sub via that event.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then 'e.g. for column H
TestFile 'name of your sub
End If
End Sub
Note I changed your LCase test as it could never be True with LCase = "Yes" and I used the typed function LCase$.
I have commented out the line for the body as this:
.Cells(cell.Row, "Ryan").Value
will throw an error. The "Ryan" part should be a column reference e.g. "A" or 1.
If the "Ryan" is a named range then you might use something like:
.Cells(cell.Row, .Range("Ryan").Column)
Code:
Option Explicit
Public Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim wb As Workbook
Set wb = ThisWorkbook
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
With ActiveSheet
For Each cell In .Columns("J").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase$(.Cells(cell.Row, "H")) = "yes" And .Cells(cell.Row, "A") = Date Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = wb.Worksheets("Server").Range("I3").Value
.Subject = "Reminder"
' .Body = "Dear " & .Cells(cell.Row, "Ryan").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
End With
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Example of Worksheet_Event code in Sheet2 code window
And the associated standard module:

Related

How to paste mulple excel range as picture to outlook at the same time

please help me fix this. I'm new to this area and I would like to paste multiple set of range from excel and paste it onto an outlook email with modified size. Please help me. Thanks in advance!
Here's my current code:
Sub EmailSend()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
StrBody = "Please see our current Report"
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "x"
.CC = "x"
.BCC = "x"
.Subject = "RRF for Vendor Sourcing - " & Cells(3, 2)
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
This line of code is what defines your range.
Set rng = Range("C4:D8").SpecialCells(xlCellTypeVisible)
You can simply define another range :
Dim rng2 As Range
Set rng2 = Range("J4:N8").SpecialCells(xlCellTypeVisible)
and then make another call to RangetoHTML() using that second range:
RangetoHTML(rng2)
which will return another string of html which you can then concatenate like this:
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & RangetoHTML(rng2)

failes to find "true" in mail to range macro

Got a macro from Ron de Bruin which I've been using, but now I can't get it to find the "TRUE" in the reference column. The "TRUE" is generated from checkboxes, it works if I write "yes" I've used the original code from his page, shown here:
Sub Test1()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _ 'right value is being shown
LCase(Cells(cell.Row, "D").Value) = "TRUE" Then 'suddenly skips this phase.
'Shows the right row but nothing happens anymore
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If I remove And _ LCase(Cells(cell.Row, "D").Value) = "TRUE" it works like a charm. I hope someone can help me out with this.
since the cell whose value you're querying is linked to a (ActiveX) checkbox its value is of a Boolean type
so you have to check it as such, that is:
If Cells(cell.Row, "D").Value Then 'means IF Cells(cell.Row, "D").Value = True
The following line is incorrect
LCase(Cells(cell.Row, "D").Value) = "TRUE" Then
you are converting the value to lowercase using the LCase function (eg true) ... you should change it to
UCase(Cells(cell.Row, "D").Value) = "TRUE" Then

Excel email macro seems to be triggered whenever a cell is populated

I have a excel spreadsheet which tracks important dates, if you have missed an invoice for that date it will automatically send out an email to the relevant person reminding them to do so. The macro functions well and works off a trigger
`
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("2015").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
If Range("Q" & r).Value = "Received" Then
Call Macro1
End If
If Range("K" & r).Value = "Overdue" Then
Call email
End If
Next r
End Sub
`
Sub email()
Dim OutApp As Object
Dim OutMail As Object
Dim FName As String
Sheets("2015").Activate
For i = 1 To 100
If Sheets("2015").Range("K" & i).Value = "Overdue" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OutMail
.To = Sheets("2015").Range("S" & i).Value
.CC = ""
.Subject = Sheets("2015").Range("B" & i).Value
.Body = "You have missed a valuation date for this project!"
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next i
End Sub
'
As you can see I am new to this so most of my code is from different examples on the internet. The problem I have is that when a cell in column K meets the requirements "Overdue" the macro will repeatedly email the user when a change in any other cell occurs. That is if K5 = "Overdue" and I go to A6 to enter a new user, the user in A5 will be emailed again. This happens for all cells until I change cell k5 to "sent".
I suspect part of the problem may also be in my e-mail macro...
I give up XD
Your macro's are working fine, I mean at least as you code them. You need to remove your macro's form FOR loops. What you can do is just getting the address of the changed cell and use it to define the mail address and subject. Something like below
** Worksheet macros**
Public mailAddress As String
Public TargetRow As Long
Public mailSubject
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = "Overdue" Then
mailAddress = Sheets("2015").Range("S" & Target.Row)
mailSubject = Sheets("2015").Range("B" & Target.Row)
TargetRow = Target.Row
Call email
ElseIf Target.Value = "Received" Then
Call Macro1
End If
End Sub
And your macro should like something like this:
Sub email()
Dim OutApp As Object
Dim OutMail As Object
Dim FName As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OutMail
.To = mailAddress
.CC = ""
.Subject = mailSubject
.Body = "You have missed a valuation date for this project!"
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you try and post answer here? I dont have excel right now, I could not try it.

Sending multiple emails from Excel

I have a workbook that has 7 worksheets. I have the below vba to send an email once a value is met on a particular sheet.
Each sheet has a different value and a different attachment to be sent. How do I add a code for each sheet so the email is sent?
Thanks in advance
Set as General (Declarations)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("M4:M368"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 3500 Then
Call Fuel_LevelW03
End If
End If
End Sub
followed by a module
General Fuel_LevelW03
Sub Fuel_LevelW03()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi" & vbNewLine & vbNewLine & _
"Please order fuel as attached." & vbNewLine & _
"" & vbNewLine & _
"Kind Regards" & vbNewLine & _
""
On Error Resume Next
With OutMail
.To = "email address"
.CC = "email address"
.BCC = ""
.Subject = "Fuel Order W03"
.Body = strbody
.Attachments.Add ("H:\Fuel Order Sheets\Glen Eden W03 Pump Station.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
From what I understand, you try to "tell the method" a bit about what the Target.Value was. Just pass the parameter to the function like this :
If IsNumeric(Target.Value) Then
If Target.Value < 3500 Then
Call Fuel_LevelW03( Sh.Name, Target.Value )
End If
End If
and change the function's name with this one :
Fuel_LevelW03( sheetName as String, targetValue as String )
'Change String to appropriate type
EDIT2 : I changed the code around a bit, if you need any help let me know.
EDIT : Ok, here's how you solve this. Inside the "ThisWorkbook" code object (underneath the sheet code objects, on the left side of the code editor), paste this :
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("M4:M368"), Target) Is Nothing Then
If IsNumeric(Target.Value) And Target.Value < 3500 Then
Call Fuel_LevelW03( Sh.Name )
End If
End If
End Sub
Sub Fuel_LevelW03( sheetName as String )
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
If sheetName = "Sheet1" Then 'Replace Sheet1 with the name of your worksheet
strbody = "Hi" & vbNewLine & vbNewLine & _
"Please order fuel as attached." & vbNewLine & _
"" & vbNewLine & _
"Kind Regards" & vbNewLine & _
"STRING BODY1"
With OutMail
.To = "email address"
.CC = "email address"
.BCC = ""
.Subject = "Fuel Order W03"
.Body = strbody
.Attachments.Add ("H:\Fuel Order Sheets\Glen Eden W03 Pump Station.xlsx")
.Send
End With
On Error GoTo 0
ElseIf sheetName = "Sheet2" Then 'Replace Sheet2 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet2"
ElseIf sheetName = "Sheet3" Then 'Replace Sheet3 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet3"
ElseIf sheetName = "Sheet4" Then 'Replace Sheet4 with the name of the next sheet and
'Put the same content as the first IF statement, but adapted to "Sheet4"
'ElseIf ............. (So on, so forth)
End If
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can add as many ElseIf's as you want (one for each sheet)
Am pretty sure this is what you need, although am not sure.
If ActiveSheet.Name = "Sheet1" Then
'Do something specific to "Sheet1"
ElseIf ActiveSheet.Name = "Sheet2" Then
'Do something specific to "Sheet2"
'And so on so forth...
End If
You have a button to that macro in each sheet, and depending on the sheet calling the macro, you want a different e-mail to be sent, right? Then this will do it. You can add as many ElseIf's as you want.

Filter and Email Excel File (VBA)

I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub