VBA stuck in a loop I can't get out of

[DrH100]

Hi all

I’ve been given the code below which seems to do almostexactly what I want it to do but I’d like to make a couple of changes which iswhere I’m stuck


AsI understand it this code identifies if a cell has been changed then if thetotal in row 21 is higher than that of row 23 provides a message and shouldremove the entry. The removal bit doesn’tseem to be working so is one of my questions

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("E28:BB128")


'   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(20, col) > Cells(22, col) Then
       MsgBox "Greater Than Threshold, Has this Been Approved?", vbYesNo
                
    If answer = vbNo Then
      
    Application.EnableEvents = False
       Application.Undo
       Application.EnableEvents = True
      
      Else
              
    End If

End If
End Sub

The other change I’d like to make is if the user says “yes”to the question I would like them to be prompted for a password. If they know it all well and good and we moveon. If they don’t or they answer “no” tothe first question then I want the entry they have input to be removed. I tried adding in something I thought mightwork but I’ve ended up getting stuck in a loop which nowhere to go. Whichever answer is given it always seems totake me back to the password bit.





Here is my edited code.

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("E28:BB128")
'   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(21, col) > Cells(23, col) Then
        MsgBox "Leave Greater Than Threshold, Has Leave Been Approved?", vbYesNo
        
        If answer = vbNo Then
     
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
       Exit Sub
       
       Else
        
Message = "Please enter your password to authourise"
 Title = "Authourise"
 
 MyValue = InputBox(Message, Title, Default)
 If MyValue <> "Password" Then
 MsgBox "Invalid password - entry removed"
 Application.Undo
 Exit Sub
 End If
                   
    End If
End If
End Sub

Hopefully someone can understand what I’m looking to do .

As always, any help appreciated.


Thanks

 

[mole999]

first thought is it is a worksheet change event, and that probably drives your endless loop

 

[Richard U]

your need to change this....

 MyValue = InputBox(Message, Title, Default)
 If MyValue <> "Password" Then
 MsgBox "Invalid password - entry removed"
 Application.Undo
 Exit Sub
 End If

to this...

 MyValue = InputBox(Message, Title, Default)
 If MyValue <> "Password" Then
 MsgBox "Invalid password - entry removed"
Application.EnableEvents = False
 Application.Undo
Application.EnableEvents = true
 Exit Sub
 End If

the absence of the Application.EnableEvents = False before your second Application.Undo is what's doing it

 

[DrH100]

Thanks very much - I haven't tested it yet as I'm not in work but will do when I get back.

Thanks for the reply

 

[Richard U]

Please let me know if it works :D

Good luck!