Excel visual basic cuestion on if statements, my second if statement doesnt work

userTbEl1 0
Viewed 36

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
vba excel
2 Answers

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
useryB020

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
VBasic20080
Related