When I try to execute the following code, the debugger is highlighting the line strbody which decides which cells get output to the email.
I'm not sure how to activate the FormulaCell so that when a value is exceeded in a column this row will be able to used to enter information to the email.
Option Explicit
Public FormulaCell As Range
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimit = 1
'Set the range with Formulas that you want to check
Set FormulaRange = Me.Range("B3:B197")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = "Not numeric"
Else
If .Value = MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook2
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
MACRO
Option Explicit
Public FormulaCell As Range
Sub Mail_with_outlook1()
'For mail code examples visit my mail page at:
'http://www.rondebruin.nl/sendmail.htm
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = "ron#something.abc"
strcc = ""
strbcc = ""
strsub = "Customers"
strbody = "Hi Ron" & vbNewLine & vbNewLine & _
"The total Customers of all stores this week is : " & Cells(FormulaCell.row, "B").Value & _
vbNewLine & vbNewLine & "Good job"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Mail_with_outlook2()
'For mail code examples visit my mail page at:
'http://www.rondebruin.nl/sendmail.htm
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = "MAIL#EMAIL.CO.UK"
strcc = ""
strbcc = ""
strsub = "S888 OVERDUE"
strbody = "THIS S888 IS NOW OVERDUE" & Cells(FormulaCell.row, "A").Value & vbNewLine & vbNewLine & _
"Your total of this week is : " & Cells(FormulaCell.row, "K:Q").Value & _
vbNewLine & vbNewLine & "HURRY UP!!"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
as Vityata already stated, the expression Cells(FormulaCell.row, "K:Q").Value isn't valid
if you need a reference to cells in column K to Q in the same row as FormulaCell Range then use
Worksheetfunction.Sum(Intersect(FormulaCell.EntireRow, Range("K:Q")))
So if you wanted to return the sum of those cells then use
strbody = "THIS S888 IS NOW OVERDUE" & Cells(FormulaCell.row, "A").Value & vbNewLine & vbNewLine & _
"Your total of this week is : " & Worksheetfunction.Sum(Intersect(FormulaCell.EntireRow, Range("K:Q"))) & _
vbNewLine & vbNewLine & "HURRY UP!!"
But there I see a hidden bug in your code where you use Public FormulaCell As Range both in Worksheet_Calculate() event handler and in your "MACRO" Module
By doing so, in you're instantiating two different Range variables, one attached to the worksheet event handler and one to the MACRO module, and without explicitly qualifying them up to their Parent object you would reference the Range variable in the currently "active" VBA module.
So, in your code before executing Call Mail_with_outlook2 statement, any FormulaCell would reference the current iterator Range variable of your For Each FormulaCell In FormulaRange.Cells loop. But as soon as the program execution gets into Mail_with_outlook2() the "resident" FormulaCell variable is still to be set and so it's Nothing
Long story short you have two choices:
get rid of Public FormulaCell As Range in MACRO module and explicitly qualify all FormulaCell references up to the Sheet object where the Worksheet_Calculate() resides
for example, assuming "Sheet1" is the name of this latter, then you'd write:
strbody = "Hi Ron" & vbNewLine & vbNewLine & _
"The total Customers of all stores this week is : " & Cells(Worksheets("Sheet1").FormulaCell.Row, "B").value & _
vbNewLine & vbNewLine & "Good job"
get rid of all Public FormulaCell As Range in both Worksheet and MACRO module and have Mail_with_outlook1() sub accept a "FormulaCell" Range parameter
so in Worksheet_Calculate(), instead of:
Call Mail_with_outlook2
you'd have:
Mail_with_outlook2 FormulaCell
and in Mail_with_outlook1(), instead of:
Sub Mail_with_outlook1()
you'd have
Sub Mail_with_outlook1(FormulaCell As Range)
The error is in this here:
Cells(FormulaCell.row, "K:Q").Value Depending on what you need, try like this:
Cells(FormulaCell.Row, "K").Value
Range("K" & FormulaCell.Row & ":Q" & FormulaCell.Row).Values
Or something else.
In general, whenever you think that the error is somewhere you know, try to make the code as smaller as possible and to see whether it runs. In your case something small is this one:
Public Sub TestMe()
Dim strBody As String
For Each FormulaCell In Range("A1:A2")
strBody = "Hi Ron" & vbNewLine & vbNewLine & _
"The total Customers of all stores this week is : " _
& Cells(FormulaCell.Row, "B").Value & _
vbNewLine & vbNewLine & "Good job"
Debug.Print strBody
Next FormulaCell
End Sub
Related
I am creating an email using VBA in Excel. For the body of the email I am taking the value of a TextBox in the excel sheet. I have enabled multiple lines in the TextBox and have put text on the first line and have text on the line below, but when I generate the email, it takes both lines of text and puts them on the same line in the email.
I need to know how to keep the line breaks in the TextBox.
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim SigString As String
Dim Signature As String
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 _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Default.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.Display
.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "<p>Dear " & Cells(cell.Row, "A").Value & ",</p>" _
& "<br><br>" & ActiveSheet.TextBox1.Value & _
.HTMLBody
.Attachments.Add ("")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Here is the TextBox1 properties
You can replace your newlines, vbNewLine, with HTML formatted line-breaks, <br>, like so:
With outMail
.display
.To = Cell.Value
.subject = "Reminder"
.HTMLBody = "<p>Dear " & Cells(Cell.row, "A").Value & ",</p>" _
& "<br><br>" & Replace(ActiveSheet.TextBox1.Value, vbNewLine, "<br>") & _
.HTMLBody
.Attachments.Add ("")
.display
End With
You can Split your string here to sperate lines
.HTMLBody = "<p>Dear " & Cells(cell.Row, "A").Value & ",</p>" _
& "<br><br>" _
& Split(ActiveSheet.TextBox1.Value, ".")(0) &"." _
& "<br>" _
& Split(ActiveSheet.TextBox1.Value, ".")(1) & "." _
& .HTMLBody
I have code in which if column I, it will look at that value and then send an email if it matches any of my limits. Then I have also included a refresh anytime I edit another column.
This code is in ThisWorkbook
Private Sub Workbook_Open()
Call Worksheet_Calculated
End Sub
This is my code in Sheet1 that will run the operation if anything in column G changes.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address Like "$F$*" Then
Call Worksheet_Calculated
End If
End Sub
This code is in a module. It checks to see if any value in column I is any of of the MyLimit Values, if it is, in column I, it will say sent or not sent. If sent, an email will be generated.
Option Explicit
Public Sub Worksheet_Calculated()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimita As Double
Dim MyLimitb As Double
Dim MyLimitc As Double
Dim MyLimitd As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimita = 100
MyLimitb = 50
MyLimitc = 10
MyLimitd = 1
'Set the range with Formulas that you want to check
'This is the column that shows how many days left
Set FormulaRange = Range("H5:H25")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = ""
ElseIf (.Value = MyLimita Or .Value = MyLimitb Or .Value = MyLimitc Or .Value = MyLimitd) Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
The above code will call another module which will populate the email that I would like to send.
Option Explicit
Public FormulaCell As Range
Public Sub Mail_with_outlook(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change the parenthesis for column that the email is in
strto = Cells(FormulaCell.Row, "K").Value
strcc = ""
strbcc = ""
strsub = "Payment Notification (PO --Enter PO # Here--)"
'Change the parenthesis for the Column that the POC is in
strbody = "Hi " & Cells(FormulaCell.Row, "J").Value & vbNewLine & vbNewLine & _
"This is a reminder to pay for a licensing/maintenance bill in: " & Cells(FormulaCell.Row, "H").Value & " days." & _
vbNewLine & vbNewLine & "Line 2" & _
vbNewLine & "Line 3" & _
vbNewLine & "Line 4" & _
vbNewLine & "Line 5" & _
vbNewLine & "Line 6"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I want to continue running this code on start up and whenever column G is edited, but only in Sheet1.
I want when column I is negative to copy that entire row into sheet2.
In VBE, I have a spreadsheet where if the column 'I' reaches 'MyLimit_', then i will automatically get an email. I am trying to make this code run only when I change a certain column (G).
This code is for the sheet.
In column I, I am looking at the these values to see if they equal my limit. if they do, it will trigger and email being generated.
Option Explicit
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimita As Double
Dim MyLimitb As Double
Dim MyLimitc As Double
Dim MyLimitd As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimita = 100
MyLimitb = 50
MyLimitc = 10
MyLimitd = 1
'Set the range with Formulas that you want to check
'This is the column that shows how many days left
Set FormulaRange = Me.Range("I5:I25")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = ""
ElseIf .Value = MyLimita Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitb Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitc Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitd Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
This code is what I put into the module. This is basically all the code I used to generate my email and then populate with the appropriate info.
Option Explicit
Public FormulaCell As Range
Sub Mail_with_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change the parenthesis for column that the email is in
strto = Cells(FormulaCell.Row, "L").Value
strcc = ""
strbcc = ""
strsub = "Payment Notification (PO --Enter PO # Here--)"
'Change the parenthesis for the Column that the POC is in
strbody = "Hi " & Cells(FormulaCell.Row, "K").Value & vbNewLine & vbNewLine & _
"This is a reminder to pay for a licensing/maintenance bill in: " & Cells(FormulaCell.Row, "I").Value & " days." & _
vbNewLine & vbNewLine & "Line 2" & _
vbNewLine & "Line 3" & _
vbNewLine & "Line 4" & _
vbNewLine & "Line 5" & _
vbNewLine & "Line 6"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can run a code automatically when the workbook is opened by calling it from the Workbook_Open() procedure.
The Worksheet_Change(ByVal Target As Range) procedure fires every time there's a chance, and then you can use the Address property of Target to see if the change was within Column G.
In the ThisWorkbook module:
Private Sub Workbook_Open()
Call YourProcedureName
End Sub
In a Sheet module:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address Like "$G$*" Then
Call YourProcedureName
End If
End Sub
In a regular module:
Public Sub YourProcedureName()
'Your code here
End Sub
Could you please help me to automatically send an email from Excel only when the formula value in column M (=IF(VAL.EMPTY(K15);"";MAX(K15-Today();0))>200. Unfortunately the Sheet1 code triggers the email code if the condition is met (>200) in formula value cell in column M if the date in column K is altered manually or by writing manually Not Sent in column N. Instead my goal would be:
1) to understand why this code in sheet1 doesn't send the email automatically as supposed to do (the only thing it does is to put Sent in column N without sending the email. This make me think that this code works)
2) to find the way to send the email automatically without changing anything manually in the cells in my sheet1.
H I J K L M N
Date Score Description Next Due Status Days till
expiration
15 28/09/2017 13 Medium Risk 25/07/2018 Valid 284 Sent
16 11/10/2017 13 Medium Risk 10/08/2018 Valid 300 Sent
'Sheet1 (FormulaValueChange)
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimit = 200
'Set the range with the Formula that you want to check
Set FormulaRange = Me.Range("M15:M16")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = "Not numeric"
Else
If .Value > MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook1(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
'Mail Code
Option Explicit
Public FormulaCell As Range
Sub Mail_with_outlook1(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = "tom#something.abc"
strcc = ""
strbcc = ""
strsub = "Assessement reminders"
strbody = "Thanks a lot"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can do it this way.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Excel 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"Cell A1 is changed" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
https://www.rondebruin.nl/win/s1/outlook/bmail9.htm
I have a slight issue with a macro. It works fine at the moment, but I need to add some code to do the following but don't know at what point to add it:
If for each cell in Column C that there is a blank cell to look for the email address on the same row but 10 columns over to the right in Column M
In the start of the body "Hi There (Column B content)
In the body of the email I would like for the macro to insert the contents from column F like this: "Please choose the following option (Column F content)
Any Ideas on how I can modify the code to include these options please.
Thank you for your time.
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
For Each cel In Range(("C2"), Range("C2").End(xlDown))
strbody = "Hi there" & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutMail
.To = cel.Value
.CC = cel.Offset(0, 10).Value
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this one:
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
Else
.To = cel.Offset(0, 10).Value & ", " & Join(Application.Index(cel.Offset(, -2).Resize(, 4).Value, 0), ", ")
End If
'.BCC = ""
.Subject = "Choose you plan"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutApp = Nothing
End Sub