Automatic Email VBA help needed

[Golfpro1286]

I hope this is as easy as it sounds, but I could not figure it out. I am using the following template to automatically generate an outlook email, which seems to be working, what I can't figure out is how to properly reference certain cells in the code. I was hoping to have the mail to address be selected from cell H3 in sheet named "Setup Sheet" and in the subject have it say "25% Inspection due for (Cell H1 in "Setup Sheet).

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("C11"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0.24 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This email is to let you know that an inspection is due for" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "25% Inspection Due for ... "
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Thanks for any help!

 

[ranman256]

.Subject = "25% Inspection Due for ... " & sheets("Setup sheet").range("H1").value

 

[Kamolga]

[COLOR=#333333]Sub Mail_small_Text_Outlook()[/COLOR]
[COLOR=#333333]Dim xOutApp As Object[/COLOR]
[COLOR=#333333]Dim xOutMail As Object[/COLOR]
[COLOR=#333333]Dim xMailBody As String[/COLOR]
[COLOR=#333333]Set xOutApp = CreateObject("Outlook.Application")[/COLOR]
[COLOR=#333333]Set xOutMail = xOutApp.CreateItem(0)[/COLOR]
[COLOR=#333333]xMailBody = "Hi there" & vbNewLine & vbNewLine & _[/COLOR]
[COLOR=#333333]"This email is to let you know that an inspection is due for" & vbNewLine & _[/COLOR]
[COLOR=#333333]"This is line 2"[/COLOR]
[COLOR=#333333]On Error Resume Next[/COLOR]
[COLOR=#000000]With xOutMail
[B].To = Worksheets("Setup Sheet").Range("H3").value
[/B].CC = ""
.BCC = ""[B]
[B].Subject = "25% Inspection Due for ... " & [/B][/B][B]Worksheets("Setup Sheet").Range("H1").value[/B][/COLOR][B][COLOR=#000000]
[/COLOR][/B][COLOR=#000000].Body = xMailBody[/COLOR]
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

 

[Golfpro1286]

Cell C11 in the code above is based on a formula. Is there a way to make that auto-calculate so you do not have to press enter on the cell? Would this cause any other issues with opening too many email messages?

 

[Michael M]

You could make the code a worksheet_calculate event, but what makes the data in c11 change ?
What is the formula ?
Surely if you are using a worksheet_change event C11 will be affected !

 

[Golfpro1286]

The code in C11 is a very simple math formula. The formula is: =B11/B10. I am not sure how to do worksheet calculte/change events. Could you provide an example?

Thanks!

 

[Michael M]

Your first code in post #1 is a worksheet_change event !!
If it is in a Sheet Module, it should be fine.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("C11"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0.24 Then
Call Mail_small_Text_Outlook
End If
End Sub

I'm guessing if you change data that affects your formula you shouldn't have to do anything else !!

 

[Golfpro1286]

Your first code in post #1 is a worksheet_change event !!
If it is in a Sheet Module, it should be fine.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("C11"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0.24 Then
Call Mail_small_Text_Outlook
End If
End Sub

I'm guessing if you change data that affects your formula you shouldn't have to do anything else !!

It was in the excel objects sheet, if I cut and paste into a new module it no longer works. I modified the code a bit to allow for some more detail and a 25% and 50% threshold email.

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("C9"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 0.24 And Target.Value < 0.5 Then
        Call Mail_small_Text_Outlook
    End If
    
Set xRg = Intersect(Range("C9"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 0.49 And Target.Value < 0.75 Then
        Call Mail_small_Text_Outlook1
    End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hello," & vbNewLine & vbNewLine & _
              "This email is to let you know that construction loan #" & Sheets("Setup Sheet").Range("K5").Value2 & " has reached the 25% disbursement threshold, and a construction inspection is required." & vbNewLine & _
              "Please schedule this inspection at your earliest convenience." & vbNewLine
              
    On Error Resume Next
    With xOutMail
        .To = Sheets("Setup Sheet").Range("H3").Value2 & ";" & Sheets("Setup Sheet").Range("H4").Value2
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Setup Sheet").Range("G5").Value2 & Sheets("Setup Sheet").Range("K5").Value2
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub


Sub Mail_small_Text_Outlook1()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Hello," & vbNewLine & vbNewLine & _
              "This email is to let you know that construction loan #" & Sheets("Setup Sheet").Range("K5").Value2 & " has reached the 50% disbursement threshold, and a construction inspection is required." & vbNewLine & _
              "Please schedule this inspection at your earliest convenience." & vbNewLine
              
    On Error Resume Next
    With xOutMail
        .To = Sheets("Setup Sheet").Range("H3").Value2 & ";" & Sheets("Setup Sheet").Range("H4").Value2
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Setup Sheet").Range("G5").Value2 & Sheets("Setup Sheet").Range("K5").Value2
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

 

[Michael M]

It was in the excel objects sheet, if I cut and paste into a new module it no longer works

It goes in the Sheet module that is relative to the action, NOT a new module

 

[Golfpro1286]

It goes in the Sheet module that is relative to the action, NOT a new module

Hmmm, it was in Sheet3(Disbursements) under the Microsoft Excel Objects in the project explorer. I wonder why it wouldn't be working?