CODEWITHSUNDEEP
vbaexcel
glasfil
glasfil

Reputation: 13

Difficulty merging 2 x Private Sub Worksheet_Change (ByVal Target As Range) in one Excel sheet

I've successfully written two macros to automate e-mailing based on cell values within a sheet (basically as a reminder system). The ranges overlap and one sub is intended to send an e-mail when cells reach a value of 0, the other is a smaller range of cells and is meant to send an e-mail when cells report a range between 1 and 5 (inclusive).

I can get the subs to work individually no problem, but my incredibly limited knowledge has been flummoxed when attempting to merge the two. Either it doesn't work at all, or it only part works.

If anyone could help me I'd be incredibly grateful as I'm at something of a loss! The code for the two subs is as follows:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value > 0 Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then

            zRow = Target.Row
            zValno = Cells(zRow, "B")
            zValname = Cells(zRow, "C")
            zValInno = Cells(zRow, "D")

            Dim OutApp As Object
            Dim OutMail As Object
            Dim strbody As String

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            strbody = ""
            strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."

            On Error Resume Next
            With OutMail
                .to = "[email protected]"
                .CC = ""
                .BCC = ""
                .Subject = "LOW VALUE: " & zValno & " is now low."
                .Body = strbody
                .Attachments.Add ("C:\reportlog.txt")
                .Send
           End With
           On Error GoTo 0

           zSent = zSent + 1
           saywhat = "processing " & zSent & " of " & zCount
           Application.StatusBar = saywhwat
           Application.StatusBar = ""

           Set OutMail = Nothing
           Set OutApp = Nothing
        End If
    End If
End If

End Sub

And

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value < 1 Then

        zRow = Target.Row
        zValno = Cells(zRow, "B")
        zValname = Cells(zRow, "C")

        Dim OutApp As Object
        Dim OutMail As Object
        Dim strbody As String

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        strbody = ""
        strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."

        On Error Resume Next
        With OutMail
            .to = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "NULL ALERT: " & zValno & " is now reporting nil."
            .Body = strbody
            .Attachments.Add ("C:\reportlog.txt")
            .Send
         End With
         On Error GoTo 0

         zSent = zSent + 1
         saywhat = "processing " & zSent & " of " & zCount
         Application.StatusBar = saywhwat
         Application.StatusBar = ""

         Set OutMail = Nothing
         Set OutApp = Nothing
    End If
End If

End Sub

Upvotes: 1

Views: 185

Answers (2)

Shai Rado
Shai Rado

Reputation: 33682

With a few modifications, try the combined code below for both Worksheet_Change events.

I've added a Variable EmailType that checks if the modified cells passed one of the 2 criteria’s, and then gets a value of 1 or 2.

Afterwards, according to the EmailType it modifies the email parameters.

Code 

Private Sub Worksheet_Change(ByVal Target As Range)

Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim mailSubject As String '<-- added this String variable to differ on 2 scenarios
Dim EmailType As Long '<-- use variable to see if passed the 2 criterias in the original code

EmailType = 0 '<-- init value
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value > 0 And Target.Value < 6 Then
        EmailType = 1 '<-- Email Type = 1
    End If
End If

If Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value < 1 Then
        EmailType = 2 '<-- Email Type = 2
    End If
End If

If EmailType = 0 Then Exit Sub '< didn't pass any of the criterias >> Exit Sub

zValno = Range("B" & Target.Row)
zValname = Range("C" & Target.Row)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Select Case EmailType
    Case 1
        zValInno = Cells("D" & Target.Row) '<-- this value exists on for Email Type 1
        mailSubject = "LOW VALUE: " & zValno & " is now low." '<-- mail subject for email type 1

        strbody = ""
        strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."

    Case 2
        mailSubject = "NULL ALERT: " & zValno & " is now reporting nil." '<-- mail subject for email type 2

        strbody = ""
        strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
End Select

' ======= from here untill the end the same code, just using different values found per Email Type =======
On Error Resume Next
With OutMail
    .to = "[email protected]"
    .CC = ""
    .BCC = ""
    .Subject = mailSubject
    .Body = strbody
    .Attachments.Add ("C:\reportlog.txt")
    .Send
End With
On Error GoTo 0

zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhat
Application.StatusBar = ""

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Upvotes: 0

SJR
SJR

Reputation: 23081

This is the brute force approach, but I think your code could be shortened as there are commonalities

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("D122:D128,D131:D133,D138,D140,D144,D188,D191:D192,D217:D220,D294,D159:D167"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value > 0 Then
        If IsNumeric(Target.Value) And Target.Value < 6 Then

            zRow = Target.Row
            zValno = Cells(zRow, "B")
            zValname = Cells(zRow, "C")
            zValInno = Cells(zRow, "D")

            Dim OutApp As Object
            Dim OutMail As Object
            Dim strbody As String

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            strbody = ""
            strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now low. This value is now " & zValInno & "."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."
            strbody = strbody & vbCr & vbCr
            strbody = strbody & "Blah, blah, blah."


            On Error Resume Next
            With OutMail
                .to = "[email protected]"
                .CC = ""
                .BCC = ""
                .Subject = "LOW VALUE: " & zValno & " is now low."
                .Body = strbody
                .Attachments.Add ("C:\reportlog.txt")
                .Send
            End With
        End If
    End If

ElseIf Not Application.Intersect(Range("D4:D100,G4:G100,J4:J99"), Target) Is Nothing Then
    If IsNumeric(Target.Value) And Target.Value < 1 Then

        zRow = Target.Row
        zValno = Cells(zRow, "B")
        zValname = Cells(zRow, "C")

        Dim OutApp As Object
        Dim OutMail As Object
        Dim strbody As String

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        strbody = ""
        strbody = strbody & "Please be advised that " & zValno & " (" & zValname & ") " & "is now reporting nil."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."
        strbody = strbody & vbCr & vbCr
        strbody = strbody & "Blah, blah, blah."

        On Error Resume Next
        With OutMail
            .to = "[email protected]"
            .CC = ""
            .BCC = ""
            .Subject = "NULL ALERT: " & zValno & " is now reporting nil."
            .Body = strbody
            .Attachments.Add ("C:\reportlog.txt")
            .Send
        End With
    End If
End If

On Error GoTo 0

zSent = zSent + 1
saywhat = "processing " & zSent & " of " & zCount
Application.StatusBar = saywhwat
Application.StatusBar = ""

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Upvotes: 2

Related Questions