CODEWITHSUNDEEP
excel
Father Goose
Father Goose

Reputation: 87

How to run Multiple Private Sub Worksheet_Change(ByVal Target As Range)?

I need to run Multiple Private Sub Worksheet_Change(ByVal Target As Range) in a Asthma/COPD STATS Chart. Gary's Student gave some much appreciated help with SUB NUMBER TWO. Is this possible, and how can I do it?

My code is as follows and works individually.

Private Sub Worksheet_Change(ByVal Target As Range)
'Change Best Peak Flow and Date Achieved

If Range("R7").Value > Range("F7").Value Then
    Range("R7").Select
    Selection.Copy
    Range("F7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("Q5").Select
    Selection.Copy
    Range("K7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
End If
End Sub

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range, rv As Long
    Set rng = Intersect(Target, Range("C77:AD81"))
    If rng Is Nothing Then Exit Sub
    For Each r In rng
        rv = r.Value
        'Peak Flow Doctor Warning
        If rv = 180 Then
            MsgBox "''PEAK FLOW CRITICAL AT 180L/MIN''" & vbCrLf & "''PREDNISONE PROBABLY REQUIRED''" & vbCrLf & "''MAKE DOCTOR'S APPOINTMENTS ASAP''", vbInformation, "WARNING"
        End If
        If rv = 120 Then
            MsgBox "''PEAK FLOW CRITICAL AT 120L/MIN''" & vbCrLf & "''MAKE URGENT DOCTOR'S APPOINTMENTS''" & vbCrLf & "''OR GO TO A&E IMMEDIATELY''", vbInformation, "CRITICAL WARNING"
        End If
        If rv >= 450 Then
            MsgBox "''CHECK OR TEST PEAK FLOW METER''" & vbCrLf & "''IT MAY BE FAULTY AND GIVING FALSE HIGH's''", vbInformation, "WARNING"
        End If
    Next r
End Sub

    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, r As Range, rv As Long
    Set rng = Intersect(Target, Range("C93:AD93"))
    If rng Is Nothing Then Exit Sub
    For Each r In rng
        rv = r.Value
        'Weight Gain Warning
        If rv = 90 Then
            MsgBox "''LIKELY TO EXACERBATE COPD SYMPTOMS''" & vbCrLf & "''CHRONIC ASTHMA OR EMPHYSEMA PROBABLE''", vbCritical, "WARNING"
        End If
        If rv = 95 Then
            MsgBox "''IF SWELLING IN ANKLES PROBABLE FLUID RETENTION''" & vbCrLf & "''POSSIBILITY OF HEART FAILURE IF UNATTENDED''", vbCritical, "CRITICAL WARNING"
        End If
      Next r
End Sub

Upvotes: 1

Views: 4562

Answers (1)

Father Goose
Father Goose

Reputation: 87

Solved the Multiple Private Sub Worksheet_Change(ByVal Target As Range) with the following code.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, r As Range, rv As Long

    If Not Intersect(Target, Range("C77:AD81")) Is Nothing Then
        Set rng = Intersect(Target, Range("C77:AD81"))
        For Each r In rng

            'Peak Flow Doctor Warning

            Select Case r.Value
                Case 180
                    MsgBox "''PEAK FLOW CRITICAL AT 180L/MIN''" & vbCrLf & "''PREDNISONE PROBABLY REQUIRED''" & vbCrLf & "''MAKE DOCTOR'S APPOINTMENTS ASAP''", vbInformation, "WARNING"
                Case 120
                    MsgBox "''PEAK FLOW CRITICAL AT 120L/MIN''" & vbCrLf & "''MAKE URGENT DOCTOR'S APPOINTMENTS''" & vbCrLf & "''OR GO TO A&E IMMEDIATELY''", vbInformation, "CRITICAL WARNING"
                Case Is >= 550
                    MsgBox "''CHECK OR TEST PEAK FLOW METER''" & vbCrLf & "''IT MAY BE FAULTY AND GIVING FALSE HIGH's''", vbInformation, "WARNING"
            End Select
        Next r
    End If
       'OraKinetics needs to change to (Target, Range("C95:AD95"))
    If Not Intersect(Target, Range("C93:AD93")) Is Nothing Then
        Set rng = Intersect(Target, Range("C93:AD93"))
        For Each r In rng

            'Weight Gain Warning

            Select Case r.Value
                Case 90
                    MsgBox "''LIKELY TO EXACERBATE COPD SYMPTOMS''" & vbCrLf & "''CHRONIC ASTHMA OR EMPHYSEMA PROBABLE''", vbCritical, "WARNING"
                Case 95
                    MsgBox "''IF SWELLING IN ANKLES PROBABLE FLUID RETENTION''" & vbCrLf & "''POSSIBILITY OF HEART FAILURE IF UNATTENDED''", vbCritical, "CRITICAL WARNING"
            End Select
        Next r
    End If

    'Change Best Peak Flow and Date Achieved

    If Range("R7").Value > Range("F7").Value Then
        Range("R7").Select
        Selection.Copy
        Range("F7").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("Q5").Select
        Selection.Copy
        Range("K7").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
End If
End Sub

Upvotes: 2

Related Questions