Range Permissions on multiple sheets

[gruntingmonkey]

I'm having a nightmare with the consistency of the below code. On some worksheets it works and others it doesn't although it doesn't fail so I have to check everything!

In the Validation Sheet, it looks up the users that should be able to access the range (which is the whole worksheet) and enters Empty if no name is given. Example is JBloggs

Sub FullPermissions()
      
      tabname = ActiveSheet.Name
      
  ''''permissions range
  Application.Calculation = xlCalculationAutomatic
Worksheets("Validation Lists").Select
Cells(2, 11).Value = tabname

    If Cells(2, 12).Value <> "" Then
        User1 = Cells(2, 12).Value
    Else
        User1 = Empty
    End If
    
        If Cells(2, 13).Value <> "" Then
            User2 = Cells(2, 13).Value
        Else
            User2 = Empty
        End If
 
 If Cells(2, 14).Value <> "" Then
        User3 = Cells(2, 14).Value
    Else
        User3 = Empty
    End If
    
        If Cells(2, 15).Value <> "" Then
            User4 = Cells(2, 15).Value
        Else
            User4 = Empty
        End If
 
 If Cells(2, 16).Value <> "" Then
        User5 = Cells(2, 16).Value
    Else
        User5 = Empty
    End If
 
    Worksheets(tabname).Select
      
On Error Resume Next
  Set ws = ThisWorkbook.Sheets(tabname)
    
    ws.Unprotect "locked"
    
    ActiveSheet.Protection.AllowEditRanges(1).Delete
    ActiveSheet.Protection.AllowEditRanges(2).Delete
    ActiveSheet.Protection.AllowEditRanges(3).Delete
    ActiveSheet.Protection.AllowEditRanges(4).Delete
    ActiveSheet.Protection.AllowEditRanges(5).Delete
    ActiveSheet.Protection.AllowEditRanges(6).Delete
    
    
  Set aer = ws.Protection.AllowEditRanges.Add("Range1", ws.[$A:$AAA])
    Set usr = aer.Users.Add(User1, True)
    Set usr = aer.Users.Add(User2, True)
    Set usr = aer.Users.Add(User3, True)
    Set usr = aer.Users.Add(User4, True)
    Set usr = aer.Users.Add(User5, True)
    
'sets range password
     ws.Protection.AllowEditRanges(1).ChangePassword _
 Password:="locked"
      
         ws.Protect "locked"
      
      Application.Calculation = xlCalculateManual
      
 
End Sub

Does anyone have any ideas?

 

[Logit]

.
I believe this part of the macro should be at the top, before any actions are taken :

'sets range password
     ws.Protection.AllowEditRanges(1).ChangePassword _
 Password:="locked"

 

[Fluff]

It probably is failing but you can't see it because of this

On Error Resume Next

Remove that line & see what happens.

 

[gruntingmonkey]

.
I believe this part of the macro should be at the top, before any actions are taken :

'sets range password
     ws.Protection.AllowEditRanges(1).ChangePassword _
 Password:="locked"

I have tested this in multiple places and the location does not seem to matter.

 

[gruntingmonkey]

It probably is failing but you can't see it because of this

On Error Resume Next

Remove that line & see what happens.

I took the error code out and indeed did get much much further!

Sub ForcePermissions()

Dim ws As Worksheet, ual As UserAccessList, aer As AllowEditRange, _
      usr As UserAccess
      
      
     For I = 6 To Sheets.Count - 2 '- number of sheets to the right +1

        tabname = Sheets(I).Name
      
'Val list updates
Worksheets("Validation Lists").Activate

    Range("K3:P100").Select
    Selection.Find(What:=tabname, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

Rownum = ActiveCell.Row

Application.EnableEvents = False

Pnm = Cells(Rownum, 11).Value
User1 = Cells(Rownum, 12).Value
User2 = Cells(Rownum, 13).Value
User3 = Cells(Rownum, 14).Value
User4 = Cells(Rownum, 15).Value
User5 = Cells(Rownum, 16).Value

On Error Resume Next

    Set ws = ThisWorkbook.Sheets(tabname)
    Worksheets(tabname).Activate
    
    ws.Unprotect "locked"
      
Application.EnableEvents = True
    ActiveSheet.Protection.AllowEditRanges(1).Delete
    ActiveSheet.Protection.AllowEditRanges(2).Delete
    ActiveSheet.Protection.AllowEditRanges(3).Delete
    

    
  Set aer = ws.Protection.AllowEditRanges.Add("Range1", ws.[$A:$AAA])
    Set usr = aer.Users.Add(User1, True)
    Set usr = aer.Users.Add(User2, True)
    Set usr = aer.Users.Add(User3, True)
    Set usr = aer.Users.Add(User4, True)
    Set usr = aer.Users.Add(User5, True)

On Error GoTo 0
'sets range password
     ws.Protection.AllowEditRanges(1).ChangePassword _
 Password:="locked"
 
    ws.Protect "locked"



Next I

Sheets("Compiler").Activate

End Sub

My only issue now is that it works if I use the code just by itself - but it doesn't seem to work if called from another module... which is weird!

 

[Fluff]

What, if anything, happens when

it doesn't seem to work if called from another module

 

[gruntingmonkey]

It does not delete the current ranges and user permissions and then replace them with the given information. It adds another incorrect range (just one row) with the correct permissions and removes the permissions from the correct range.

Sorry, I'm not being helpful with all the information here...

 

[Fluff]

The code you posted in post#5 still has on error resume next.
Try removing that & see what happens

 

[gruntingmonkey]

ahh, I turn it off after the users have been selected (On Error GoTo 0). If I dont do this, when one of the users or ranges is Empty it debugs.

Having the on error there makes no difference.

 

[Fluff]

In that case I'm afraid I can't help any further