CODEWITHSUNDEEP
excelvbaemailconditional-statements
L.Writer
L.Writer

Reputation: 87

Excel VBA - send mail based on condition only working for first range

I would like to send a email based on a condition for different cells and different condition. Unfortunately my code is only working for the first range ("A4" to "H4").

If I change something else it won't be triggered. Any ideas how to fix this?

Additional: I would like to write the 4 cells above the affected cell inside the email. e.g. A4 will trigger the condition I would like to write the value of "A2, A3 B2, B3" inside the email. Somebody may have an idea how to pick a area of 4x4 above the affected cell?! Is this possible or do I need to harcdoce this inside my code?!

Thanks.

btw: I know my code is quite bad, but I'm very new at VBA, soo I'm just happy if it's working. :D

Originally code:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next

    Dim rg1, rg2, rg3, rg4, rg5, rg6, rg7, rg8, rg9, rg10 As Range
    Dim rg11, rg12, rg13, rg14, rg15, rg16, rg17, rg18, rg19, rg20 As Range

  Set rg1 = Intersect(Range("A4", "H4"), Target)
    If rg1 Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value < 21 Then
        Call Mail_small_Text_Outlook
    End If
' ... similar for all ranges (with different range and condition)
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)
    If MsgBox("Senden?", vbOKCancel) = vbOK Then
         xMailBody = "test" & vbNewLine & vbNewLine & _
              "test2" & vbNewLine & _
              "test3"
        On Error Resume Next
        With xOutMail
            .To = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "send by cell value test"
            .Body = xMailBody
            .Display   'or use .Send
        End With
        On Error GoTo 0
        Set xOutMail = Nothing
        Set xOutApp = Nothing
        MsgBox "Mail verschickt!"
    Else
        MsgBox "Abgebrochen!"
    End If
End Sub

Update (new Code):

I have changed my code a little bit, unfortunately I have now a "infinity" loop, sending a mail is now triggered around 10 times... May somebody is able to see the issue why this is occuring? (now at least it's triggered for every cell I want)

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next

    If Intersect(Range("A4", "H4"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("I4", "L4"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A10", "D10"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("E10", "H10"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("I10"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 51 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("K10"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A16", "F16"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("G16", "J16"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("K16"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 3 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A22", "L22"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A28", "F28"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A57"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 26 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("D57"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 16 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("G57"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A65"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("D65", "H65"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A79", "E79"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A94", "H94"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A100", "H100"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
        End If
    End If

    If Intersect(Range("A106"), Target) Then
        If IsNumeric(Target.Value) And Target.Value < 2 Then
            Call Mail_small_Text_Outlook
        End If
    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)
    If MsgBox("Senden?", vbOKCancel) = vbOK Then
         xMailBody = "test" & vbNewLine & vbNewLine & _
              "test2" & vbNewLine & _
              "test3"
        On Error Resume Next
        With xOutMail
            .To = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "send by cell value test"
            .Body = xMailBody
            .Display   'or use .Send
        End With
        On Error GoTo 0
        Set xOutMail = Nothing
        Set xOutApp = Nothing
        MsgBox "Mail verschickt!"
    Else
        MsgBox "Abgebrochen!"
    End If
End Sub

Update2:

Great, it's now working with this code:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next


    If Not Intersect(Range("A4", "H4"), Target) Is Nothgin Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("I4", "L4"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A10", "D10"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("E10", "H10"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("I10"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 51 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("K10"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A16", "F16"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 31 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("G16", "J16"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("K16"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 3 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A22", "L22"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A28", "F28"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A57"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 26 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("D57"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 16 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("G57"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A65"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("D65", "H65"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A79", "E79"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A94", "H94"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A100", "H100"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If

    If Not Intersect(Range("A106"), Target) Is Nothing Then
        If IsNumeric(Target.Value) And Target.Value < 2 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    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)
    If MsgBox("Senden?", vbOKCancel) = vbOK Then
         xMailBody = "test" & vbNewLine & vbNewLine & _
              "test2" & vbNewLine & _
              "test3"
        On Error Resume Next
        With xOutMail
            .To = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "send by cell value test"
            .Body = xMailBody
            .Display   'or use .Send
        End With
        On Error GoTo 0
        Set xOutMail = Nothing
        Set xOutApp = Nothing
        MsgBox "Mail verschickt!"
    Else
        MsgBox "Abgebrochen!"
    End If
End Sub

Upvotes: 1

Views: 469

Answers (1)

Lukas Kavicky
Lukas Kavicky

Reputation: 64

There are few issues with your code:

  1. If rg1 Is Nothing Then Exit Sub: This says that if there is no intersection between Target and Range("A4", "H4") then the sub should exit. I suppose you've meant that the following condition should be evaluated only if there was an intersection, so something like this:

    If Not rg1 Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value < 21 Then
        Call Mail_small_Text_Outlook
    End If`
End If

  2. There is short circuit evaluation of Logical operators in VBA. This means that when you write If x And y Then both x and y will be evaluated. In your case it means that even if IsNumeric(Target.Value) is false the Target.Value < 21 will be evaluated. If Target.Value is some string, it will raise an error.

  3. [Added] There is no need to evaluate the other intersections if one was already found. You should exit the sub:

    If Not rg1 Is Nothing Then
    If IsNumeric(Target.Value) Then
        If Target.Value < 21 Then
            Call Mail_small_Text_Outlook
            Exit Sub
        End If
    End If
End If

  4. [Added2] You can't assume that Target in Worksheet_Change will allways be a one-cell range. E.g. if I copy a value, select multiple cells and paste the value, I will change values of multiple cells at once and the Target of Worksheet_Change will be made of all the cells. Depending on what you want to do, you may want to evaluate just the first cell of the range or loop through all the cells:

    Dim cell as Excel.Range
For Each cell In Target.Cells
    If Not Not Intersect(Range("A4", "H4"), Target) Is Nothing Then
        If IsNumeric(Target.Value) Then
            If Target.Value < 21 Then
                Call Mail_small_Text_Outlook
                Exit Sub
            End If
        End If
    End If
    '...
Next

    As a side note:

    • in general try to avoid On Error Resume Next and do a proper error handling
    • [Edited!] in your code, there is no need for the declaration of that many ranges. The could would be more readable if you write the ifs as If Not Intersect(Range("A4", "H4"), Target) Is Nothing Then

Upvotes: 1

Related Questions