Sending multiple emails from Excel - vba

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.

Related

Excel VBA If Else Statement stops code

In my Excel File I have a CommandButton which sends an E-Mail if cells E1, K2 and K5 are filled.
Unfortunately my code does not really work.
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim nameList As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error GoTo cleanup
If Sheets("Sheetname").Range("E1").Value = "" Or _
Sheets("Sheetname").Range("K2").Value = "" Or _
Sheets("Sheetname").Range("K5").Value = "" Then
MsgBox "The Cells E1, K2 and K5 has to be filled!"
Else
MsgBox "All Cells are filled, send E-Mail now"
For i = 2 To 22
If Sheets("efforts and risks").Range("BB2").Value <> "" Then
nameList = nameList & ";" & Sheets("efforts and risks").Range("BB" & i).Value
End If
Next
With OutMail
.To = nameList
.Subject = "subject line"
.Body = "Body Text"
.Send
End With
End If
cleanup:
Set OutApp = Nothing
End Sub
If the cells are filled Excel shows the MsgBox, but it does not send the mail. Which part of my code do I have to change?
Hope someone can help me. Thanks a lot

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

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:

Can't send multiple Outlook Messages

I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub

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.

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