Worksheet Change

[DrH100]

Morning all

I was very kindly provided the code below which produces a message should the value of one cell (row 39) exceed the value of another (row 41) as users change data in a column. That works great.

What I would like to do is change it ever so slightly in that I would like the message to only appear if the user is "adding" data to the column rather than if they are removing. Ie if they remove data from the column but row 39 still exceeds row 41 no message is shown (as they are making the position better).

Is this possible at all?

The code I am using is below.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range
   Dim col As Long

'  Set range to apply this to
   Set myRange = Range("E47:BB1000")

'  Exit if more than one cell updated at a time
If Target.CountLarge > 1 Then Exit Sub

' Exit if cell updated is outside of designated range
If Intersect(Target, myRange) Is Nothing Then Exit Sub

'Get number of updated column
col = Target.Column

'Check to see if row 1 is greater than row 2 in that column
If Cells(39, col) > Cells(41, col) Then
MsgBox "This entry exceeds the agreed threshold, If you are adding leave please ensure this is has been agreed with your line manager", vbOK


'If answer = vbNo Then

Else

   End If

End Sub

As always, any help appreciated.

Thanks

 

[Yongle]

Does this achieve what you want ?

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim myRange As Range
    Dim col As Long

'  Set range to apply this to
    Set myRange = Range("E47:BB1000")
'  Exit if more than one cell updated at a time
    If Target.CountLarge > 1 Then Exit Sub
' Exit if cell updated is outside of designated range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub

' Exit if cell contains no value
    If Target.Value = "" Then Exit Sub

' Get number of updated column
    col = Target.Column
' Check to see if row 1 is greater than row 2 in that column
    If Cells(39, col) > Cells(41, col) Then
        MsgBox "This entry exceeds the agreed threshold, If you are adding leave please ensure this is has been agreed with your line manager", vbOK
' If answer = vbNo Then
    Else

    End If

End Sub

 

[Snakehips]

I was thinking that entries in the column are causing row 39 to increase or decrease.
So maybe this?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range
Dim col As Long
Dim PrevVal As Variant
'  Set range to apply this to
   Set myRange = Range("E47:BB1000")

'  Exit if more than one cell updated at a time
If Target.CountLarge > 1 Then Exit Sub

' Exit if cell updated is outside of designated range
If Intersect(Target, myRange) Is Nothing Then Exit Sub

'Get number of updated column
col = Target.Column
'Get previous value of row 39
Application.EnableEvents = False
  Application.Undo
  PrevVal = Cells(39, col)
  Application.Undo
Application.EnableEvents = True

'Check to see if row 1 is greater than row 2 in that column  AND of increases value
If Cells(39, col) > Cells(41, col) And Cells(39, col) > PrevVal Then

MsgBox "This entry exceeds the agreed threshold, If you are adding leave please ensure this is has been agreed with your line manager", vbOK


'If answer = vbNo Then

Else

   End If

End Sub

 

[DrH100]

Does this achieve what you want ?

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim myRange As Range
    Dim col As Long

'  Set range to apply this to
    Set myRange = Range("E47:BB1000")
'  Exit if more than one cell updated at a time
    If Target.CountLarge > 1 Then Exit Sub
' Exit if cell updated is outside of designated range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub

' Exit if cell contains no value
    If Target.Value = "" Then Exit Sub

' Get number of updated column
    col = Target.Column
' Check to see if row 1 is greater than row 2 in that column
    If Cells(39, col) > Cells(41, col) Then
        MsgBox "This entry exceeds the agreed threshold, If you are adding leave please ensure this is has been agreed with your line manager", vbOK
' If answer = vbNo Then
    Else

    End If

End Sub

Sorry its taken a couple of days to reply but that works perfectly - tvm

 

[DrH100]

I was thinking that entries in the column are causing row 39 to increase or decrease.
So maybe this?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range
Dim col As Long
Dim PrevVal As Variant
'  Set range to apply this to
   Set myRange = Range("E47:BB1000")

'  Exit if more than one cell updated at a time
If Target.CountLarge > 1 Then Exit Sub

' Exit if cell updated is outside of designated range
If Intersect(Target, myRange) Is Nothing Then Exit Sub

'Get number of updated column
col = Target.Column
'Get previous value of row 39
Application.EnableEvents = False
  Application.Undo
  PrevVal = Cells(39, col)
  Application.Undo
Application.EnableEvents = True

'Check to see if row 1 is greater than row 2 in that column  AND of increases value
If Cells(39, col) > Cells(41, col) And Cells(39, col) > PrevVal Then

MsgBox "This entry exceeds the agreed threshold, If you are adding leave please ensure this is has been agreed with your line manager", vbOK


'If answer = vbNo Then

Else

   End If

End Sub

Thanks - I haven't tried this one as the earlier response sorted my issue but out of interest I will try this one at a later date and see - TVM