Make the code work in a protected sheet

D

dslhs

Board Regular
Joined
Apr 4, 2022
Messages
50
Office Version
  1. 2019
Platform
  1. Windows
Hello,

I know there's a way of doing it, but I'm failing continually.

I have this wonderful VBA that works brilliantly when the sheet is unprotected:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
  
    Application.EnableEvents = False
    On Error GoTo Exitsub       'Avoid On Error if not strictly necessary
    If Not Intersect(Target, Range("N3:N163,O3:O163,P3:P163,Q3:Q163")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then
                GoTo Exitsub
            Else
                Application.EnableEvents = False
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
            End If
        End If
    End If

Exitsub:
    On Error GoTo 0     ' linked to the on error above. Avoid On Error if not strictly necessary
    Application.EnableEvents = True
End Sub

However, I would like to change it so that it can work on a protected sheet. I'm aware the code will need to unprotect, run, then protect again, but I can't seem to make it work. Please can you let me know how to modify the above VBA to do so.

Many thanks!
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
Try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = False
    On Error GoTo Exitsub       'Avoid On Error if not strictly necessary
    If Not Intersect(Target, Range("N3:N163,O3:O163,P3:P163,Q3:Q163")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then
                GoTo Exitsub
            Else
                Application.EnableEvents = False
                ActiveSheet.Unprotect
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
                ActiveSheet.Protect
            End If
        End If
    End If

Exitsub:
    On Error GoTo 0     ' linked to the on error above. Avoid On Error if not strictly necessary
    Application.EnableEvents = True
End Sub
 
Upvote 0
Thanks for trying, but no - it doesn't work. The VBA no longer functions when the sheet is protected. Weirdly also, when I try to turn off the protection - all the settings are returned to default...

1731948576912.png

After I tried your VBA^




1731948559567.png

Before your VBA^

Is it something to do with the password? The sheet it password protected. Would that need to go into the VBA somewhere?
 
Upvote 0
Replace the text in red with your actual password.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = False
    On Error GoTo Exitsub       'Avoid On Error if not strictly necessary
    If Not Intersect(Target, Range("N3:N163,O3:O163,P3:P163,Q3:Q163")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then
                GoTo Exitsub
            Else
                Application.EnableEvents = False
                ActiveSheet.Unprotect "YourPassword"
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
                ActiveSheet.Protect "YourPassword"
            End If
        End If
    End If

Exitsub:
    On Error GoTo 0     ' linked to the on error above. Avoid On Error if not strictly necessary
    Application.EnableEvents = True
End Sub
 
Upvote 0
Thanks for trying - still doesn't work
mumps said:
Replace the text in red with your actual password.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Application.EnableEvents = False
    On Error GoTo Exitsub       'Avoid On Error if not strictly necessary
    If Not Intersect(Target, Range("N3:N163,O3:O163,P3:P163,Q3:Q163")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            If Target.Value = "" Then
                GoTo Exitsub
            Else
                Application.EnableEvents = False
                ActiveSheet.Unprotect "YourPassword"
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
                ActiveSheet.Protect "YourPassword"
            End If
        End If
    End If

Exitsub:
    On Error GoTo 0     ' linked to the on error above. Avoid On Error if not strictly necessary
    Application.EnableEvents = True
End Sub
Click to expand...
 
Upvote 0
Hi
not tested but see if this update will work for you

VBA Code: 
Dim KeyCells        As Range
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue    As String, Newvalue As String
   
    On Error GoTo Exitsub
    If Not Intersect(Target, KeyCells) Is Nothing Then
        If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            If Len(Target.Value) > 0 Then
                Application.EnableEvents = False
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
            End If
        End If
    End If
   
Exitsub:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
    'add password as required
    Const strPassword As String = ""
   
    If KeyCells Is Nothing Then Set KeyCells = Me.Range("N3:N163,O3:O163,P3:P163,Q3:Q163")
    If Not Intersect(Target, KeyCells) Is Nothing Then
        Me.Unprotect Password:=strPassword
    Else
        Me.Protect Password:=strPassword
    End If
End Sub

Note the variable at the top of the procedure. It MUST be placed at very TOP of your worksheet code page OUTSIDE any procedure.

Dave
 
Upvote 0
dmt32 said:
Hi
not tested but see if this update will work for you

VBA Code: 
Dim KeyCells        As Range
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue    As String, Newvalue As String
  
    On Error GoTo Exitsub
    If Not Intersect(Target, KeyCells) Is Nothing Then
        If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            If Len(Target.Value) > 0 Then
                Application.EnableEvents = False
                Newvalue = Target.Value
                Application.Undo
                Oldvalue = Target.Value
                If Oldvalue = "" Then
                    Target.Value = Newvalue
                Else
                    If InStr(1, Oldvalue, Newvalue) = 0 Then
                        Target.Value = Oldvalue & "," & vbLf & Newvalue
                    Else:
                        Target.Value = Oldvalue
                    End If
                End If
            End If
        End If
    End If
  
Exitsub:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  
    'add password as required
    Const strPassword As String = ""
  
    If KeyCells Is Nothing Then Set KeyCells = Me.Range("N3:N163,O3:O163,P3:P163,Q3:Q163")
    If Not Intersect(Target, KeyCells) Is Nothing Then
        Me.Unprotect Password:=strPassword
    Else
        Me.Protect Password:=strPassword
    End If
End Sub

Note the variable at the top of the procedure. It MUST be placed at very TOP of your worksheet code page OUTSIDE any procedure.

Dave
Click to expand...
Thanks, but doesn't work, I'm afraid. Same issue. I put it to the top - there are no other procedures. Any other ideas? To confirm, I add the password to Const strPassword As String = "[PASSWORD HERE]"
 
Upvote 0
Then suggest you place a copy of your workbook (with dummy data) on a file sharing like dropbox & provide a link to it here.

Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Trying to apply 2 Worksheet Changes
Replies
1
Views
234
Joe4
Joe4
H
  • Question Question
Using VBA to select multiple criteria in 2 dropdown lists on the same sheet
Replies
1
Views
429
My Aswer Is This
My Aswer Is This
welshraz
  • Question Question
VBA - Restrict Code to One Column for Multi-choice Dropdown
Replies
2
Views
129
welshraz
welshraz
S
  • Question Question
VBA code for Multiple selections in dropdown list
Replies
1
Views
501
Artik
Artik
D
  • Solved
VBA to deselect a single value in a multi-selection drop down list.
Replies
1
Views
856
smozgur
smozgur

Forum statistics

Threads
1,224,812
Messages
6,181,098
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top