I have a spreadsheet that sorts and reorders data automatically after a user makes a change to the data. This is done through Private Sub Worksheet_Change. Part of the code is to unprotect the sheet and than protect it again after changes have been made. I am using the 'Allow users to edit ranges' feature so that some user can edit some columns while others can edit all of them. They are required to enter a password when they try to change a cell. The problem is that they are prompted to enter the password on every cell they try to edit. They should only be required to enter the password once. I have narrowed to problem down to the "Sheet("Sheet1").protect" code in the Worksheet_Change sub. It seems to reset the password protection on the 'Allow users to edit ranges". Does anyone know a way around this?
Here is the code. The problems still happens if I remove everything and leave only "Sheet("Sheet1").protect".
Here is the code. The problems still happens if I remove everything and leave only "Sheet("Sheet1").protect".
Code:
Private Sub Worksheet_Change(ByVal Tgt As Range)
Const iPriCol As Long = 1 ' column containing task priority
Const iRowBeg As Long = 2 ' first row in range
Dim r As Range
Dim iRowEnd As Long ' last row in range
Dim iRow As Long ' row index
Dim OrigPriority As Long
Dim NewPriority As Long
Dim PromoDemo As String
Sheets("Sheet1").Select
iRowEnd = Cells(100, iPriCol).End(xlUp).Row ' last non-blank cell in priority column
Set r = Cells(iRowBeg, iPriCol).Resize(iRowEnd - iRowBeg + 1).EntireRow
If Tgt.Rows.Count = 1 And Tgt.Columns.Count = 1 Then
If Tgt.Column = iPriCol And Not Intersect(Tgt, r) Is Nothing Then
Application.EnableEvents = False
NewPriority = Tgt
Application.Undo
OrigPriority = Tgt
If NewPriority > OrigPriority Then PromoDemo = "Promote"
If NewPriority < OrigPriority Then PromoDemo = "Demote"
If NewPriority = OrigPriority Then PromoDemo = "NoChange"
If PromoDemo = "Demote" Then
For iRow = iRowBeg To iRowEnd
If iRow = Tgt.Row Then
Cells(iRow, iPriCol) = NewPriority
Else
If Cells(iRow, iPriCol) < OrigPriority And Cells(iRow, iPriCol) >= NewPriority Then
Cells(iRow, iPriCol) = Cells(iRow, iPriCol) + 1
End If
End If
Next iRow
ElseIf PromoDemo = "Promote" Then
For iRow = iRowBeg To iRowEnd
If iRow = Tgt.Row Then
Cells(iRow, iPriCol) = NewPriority
Else
If Cells(iRow, iPriCol) > OrigPriority And Cells(iRow, iPriCol) <= NewPriority Then
Cells(iRow, iPriCol) = Cells(iRow, iPriCol) - 1
End If
End If
Next iRow
End If
Application.EnableEvents = True
End If
Sheets("Sheet1").Unprotect (3250)
Range("A2:F46").Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Sheets("Sheet1").Protect (3250)
End If
End Sub