Crashing!!!

[Pasty]

I have this code sat in sheet 5 ("Risk By Functions") and the first bit was
working fine until I put in a loop and message box to make sure people enter
a reason why the controls aren't working. Now it still works but when I try
and take the information out of the cells it causes my spreadsheet to crash.
The code is as below. Would anyone be able to help me with this?

Private Sub worksheet_change(ByVal Target As Range)
Application.ScreenUpdating = False
Do Until Target.Offset(0, 1) <> ""
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("P2296")) Is Nothing Then
If Target.Value = "No" Then
Response = InputBox("Why are the controls not working?")
Target.Offset(0, 1).Value = Response
If Target.Value = "No" And Response = "" Then
MsgBox "You have not entered a reason why", vbCritical
End If
End If
End If
Loop
If Target.Column = 23 Then
If Target <> Cells(Target.Row, 22) Then

ReasonWhy = InputBox("Enter Reason date was Pushed back")
Cells(Target.Row, 24) = ReasonWhy

End If

End If
Application.ScreenUpdating = True
End Sub

 

[Vergel Adriano]

Try placing your loop inside the If statement like this:

If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("P2296")) Is Nothing Then
If Target.Value = "No" Then
Do Until Target.Offset(0, 1) <> ""
Response = InputBox("Why are the controls not working?")
Target.Offset(0, 1).Value = Response
If Target.Value = "No" And Response = "" Then
MsgBox "You have not entered a reason why", vbCritical
End If
Loop
End If
End If