I'm trying to make excel send automated emails when different cells get to different values, my first if statement works, which is when cell D6 goes over 400, now my next if statement doesn't work, which is when cell D7 goes over 400. I have to at least add 2 more if statements like this for cell D8 and D9. Here is the code:
Dim R As Range
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Set R = Intersect(Range("D6"), Target)
If R Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 400 Then
Call send_mail_outlook
End If
'second part to check for
If Target.Cells.Count > 1 Then Exit Sub
Set R = Intersect(Range("D7"), Target)
If R Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 400 Then
Call send_mail_outlook1
End If
End Sub
Sub send_mail_outlook()
Dim x As Object
Dim y As Object
Dim z As String
Set x = CreateObject("Outlook.Application")
Set y = x.CreateItem(0)
z = "Hola!" & vbNewLine & vbNewLine & _
"xxx" & vbNewLine & _
"xx"
On Error Resume Next
With y
.To = "xxx@ss"
.cc = ""
.BCC = ""
.Subject = "xxx"
.Body = z
.Display
End With
On Error GoTo 0
Set y = Nothing
Set x = Nothing
End Sub
Sub send_mail_outlook1()
Dim x As Object
Dim y As Object
Dim z As String
Set x = CreateObject("Outlook.Application")
Set y = x.CreateItem(0)
z = "ss!" & vbNewLine & vbNewLine & _
"sss" & vbNewLine & _
"sss"
On Error Resume Next
With y
.To = "xx@ss"
.cc = ""
.BCC = ""
.Subject = "xxx"
.Body = z
.Display
End With
On Error GoTo 0
Set y = Nothing
Set x = Nothing
End Sub
CodePudding user response:
Not totally clear on your use case, but something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v
If Target.Cells.Count > 1 Then Exit Sub 'single-cell changes only...
v = Target.Value
If Len(v) = 0 Then Exit Sub 'no value entered
If IsNumeric(v) Then
If v > 400 Then
Select Case Target.Address(False, False) 'which cell was changed?
Case "D6": send_mail_outlook 'use of Call is deprecated
Case "D7": send_mail_outlook1
End Select
End If
End If
End Sub
CodePudding user response:
A Worksheet Change: Send Mail
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
ValidateAndSendMail Target
End Sub
Sub ValidateAndSendMail(ByVal Target As Range)
' Make sure that all of the arrays contain the same number of elements!
' 'VBA.' in front of 'Array' is used to ensure a zero-based array.
Dim tAddresses() As Variant: tAddresses = VBA.Array("D6", "D7", "D8", "D9")
Dim tNumbers() As Variant: tNumbers = VBA.Array(400, 400, 400, 400)
Dim tTo() As Variant: tTo = VBA.Array("xxx@ss", "xx@ss", "aa@ss", "bb@ss")
Dim tCC() As Variant: tCC = VBA.Array("", "", "", "")
Dim tBCC() As Variant: tBCC = VBA.Array("", "", "", "")
Dim tSubject() As Variant: tSubject = VBA.Array("xxx", "xxx", "xxx", "xxx")
Dim tBody() As String: ReDim tBody(0 To 3)
tBody(0) = "Hola!" & vbLf & vbLf & "xxx" & vbLf & "xx"
tBody(1) = "ss!" & vbLf & vbLf & "sss" & vbLf & "sss"
tBody(2) = "aa!" & vbLf & vbLf & "aaa" & vbLf & "aaa"
tBody(3) = "bb!" & vbLf & vbLf & "bbb" & vbLf & "bbb"
Dim tAddress As String: tAddress = Target.Address(0, 0)
Dim tIndex As Variant: tIndex = Application.Match(tAddress, tAddresses, 0)
If IsError(tIndex) Then Exit Sub ' target address not found in array
Dim tValue As Variant: tValue = Target.Value
If Not VarType(tValue) = vbDouble Then Exit Sub ' not a number
Dim tNumber As Double: tNumber = CDbl(tValue)
Dim i As Long: i = CLng(tIndex) - 1
If tNumber > tNumbers(i) Then
SendMail tTo(i), tCC(i), tBCC(i), tSubject(i), tBody(i)
End If
End Sub
Sub SendMail( _
ByVal smTo As String, _
ByVal smCC As String, _
ByVal smBCC As String, _
ByVal smSubject As String, _
ByVal smBody As String)
With CreateObject("Outlook.Application")
With .CreateItem(0)
On Error Resume Next
.To = smTo
.CC = smCC
.BCC = smBCC
.Subject = smSubject
.Body = smBody
.Display
On Error GoTo 0
End With
End With
End Sub