Worksheet Change and Worksheet Activate Events Reprotecting Automatically

[exceltracker02]

Cross-posted:

Have a worksheet where I'm trying to code in three things:

1) An Auto-Sort once data is entered in columns 1-7
2) A worksheet change event that runs my main macro when data in the table is changed
3) A security feature that locks cells in column 7 when column 10 = "Yes"

I've used the following code to achieve this:

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="wolfpack"
If Target.Column = 7 Then Range("A20:L1000").Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=xlGuess _
        , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
ActiveSheet.Protect Password:="wolfpack", _
        DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
Dim rng As Range
Set rng = Range("A20:L1000")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, rng) Is Nothing Then Exit Sub
Call Auto_Open
End Sub

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="wolfpack"
Dim rng As Range
Dim rngM As Range

Set rngM = Range("J20:J1000")

For Each x In rngM
    If x = "Yes" Then
    x.Offset(0, -3).Locked = True
    Else
    End If
Next x
ActiveSheet.Protect Password:="wolfpack", _
        DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
End Sub

The problem is for the "Approvers", who have the password and will be the ones entering "Yes" in column 10. Right now, each time there's an entry the sheet re-protects. So were the approver to have 20 rows to approve, they'd need to unprotect the sheet manually 20 times which is very burdensome. I've considered having a login that would disable events, but I want the worksheet change event in particular to be active while the approver works. Any suggestions for a workaround?

 

[RoryA]

If this is a cross-post, please add links to the other posts. Thank you.

 

[Andrew Poulsom]

You If ... Then is wrong here:

If Target.Column = 7 Then Range("A20:L1000").Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=xlGuess _
        , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
ActiveSheet.Protect Password:="wolfpack", _
        DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True
Dim rng As Range
Set rng = Range("A20:L1000")

The other 3 lines aren't within the construct. Try:

    If Target.Column = 7 Then
        Range("A20:L1000").Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=xlGuess _
            , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        ActiveSheet.Protect Password:="wolfpack", _
            DrawingObjects:=False, Contents:=True, Scenarios:= _
            False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
            AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
            :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
            AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
            AllowUsingPivotTables:=True
        Dim rng As Range
        Set rng = Range("A20:L1000")
    End If

 

[exceltracker02]

Thanks for the response. Adding that End If is giving the following Compile Error: "End If Without Block If". Also tried to edit the original post to add in cross-post link but didn't see the edit option. The cross post is here.

 

[Andrew Poulsom]

I guess you didn't break this into two lines like I did:

If Target.Column = 7 Then Range("A20:L1000").Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=xlGuess _
        , OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal