Protect but Allow Edit Ranges in Multiple Sheets

[EugeniaP]

Hi, there!

Can anyone please help with a solution to the following problem:

I have 20 similar workbooks with exactly the same worksheets that are just
named differently. For example, Workbook 1 is East Division, and the sheets
are New York, New Jersey, Massachusetts - they are exactly the same sheets.
Workbook 2 is South Division, and the sheets are Florida, Alabama, Kentucky -
again, same sheets as in East Division, etc.
Here is my question. Is it possible to create a macro that would
simultaneously allow users to edit range B1:B32 in each of the sheets AND
protect each of the sheets within a workbook? Would this macro be applicable
to all of the other 19 workbooks.
Please help! I can't imagine having to go into each of the sheets in every
workbook and manually set up "allow user to edit range" and "protect sheet"
modes. It'll take me forever.

Thank you in advance!
E.P.

 

[Sheeloo]

To loop through the sheets use;
Sub protectSheets
Dim mySheet As Worksheet

For Each mySheet In Worksheets

' protect your range
' Record a macro for one sheet to get the code to be put here

Next mySheet
End Sub

 

[EugeniaP]

Here's what I came up with, but line 4 is giving me the application-defined
or object-defined error:

Sub protectSheets()
Dim mySheet As Worksheet

For Each mySheet In Worksheets

mySheet.Protection.AllowEditRanges.Add Title:="Range 1",
Range:=Range("D1014,D1632,D3435")
mySheet.Protect Password:="214sg1"

Next mySheet
End Sub


What am I doing wrong?

 

[Sheeloo]

I will look into this tonight... unless someone else answers this before
that...

I think you need to set range on all sheets through the loop and then
protect the workbook outside the loop. Also name should be different for each
sheet... you can have a variable say i and append it to the name and
increment by one

 

[EugeniaP]

Sheeloo,

Thanks for taking your time to look into this. I really appreciate it.

 

[Sheeloo]

Here is the code;
(Adapted from http://www.tanguay.info/web/codeExample.php?id=896)

You need to call the macro protectSheets()
Each sheet should have a range named MyRange1, MyRange2,... for first,
second,... sheets.

You may adapt it as per your requirements.

Let me know how it goes.

'___________
'tool: protects any number of areas (ranges) of a sheet, send them
semi-colon separated as e.g. "A1:F20;B1:B100"
Function qexc_ProtectAreaOfSheet(strSheetName As String,
strRangeNamesToProtect As String, strPassword As String)

'declarations
Dim arrRangeNames() As String
Dim intIndex As Integer

'variables
arrRangeNames = qstr_BreakIntoParts(strRangeNamesToProtect, ";")

'unprotect the sheet so you can unlock the cells
Sheets(strSheetName).Unprotect (strPassword)

'unlock all cells in sheet
Sheets(strSheetName).Cells.Locked = False

'lock the cells that you want to protect
For intIndex = 0 To UBound(arrRangeNames)

'variables
strrangeName = arrRangeNames(intIndex)

'lock cells for this range
Sheets(strSheetName).Range(strrangeName).Locked = True

Next

'protect the range they specified
Sheets(strSheetName).Protect Password:=strPassword, Contents:=True,
Scenarios:=True, UserInterfaceOnly:=True

End Function

'tool: this function acts like split, but also trims, takes e.g. "log1.txt,
log2.txt, log3.txt" and returns the array("log1.txt", "log2.txt", "log3.")
without the spaces on the left isde
Function qstr_BreakIntoParts(ByVal strLine As String, strSeparator As String)

'declarations
Dim ra() As String
Dim arrParts() As String
Dim intNumberOfParts As Integer
Dim intIndex As Integer
Dim strPart As Variant
Dim strCleanedPart As String

'variables
arrParts = Split(strLine, strSeparator)
intNumberOfParts = UBound(arrParts) + 1
ReDim Preserve ra(intNumberOfParts - 1)

'assign
intIndex = 0
For Each strPart In arrParts

'variables
strCleanedPart = Trim(strPart)

'add it
ra(intIndex) = strCleanedPart

'increment
intIndex = intIndex + 1

Next

qstr_BreakIntoParts = ra

End Function

Sub protectSheets()
Dim mySheet As Worksheet
Dim rngName As String
Dim rngOnSheet As String
Dim i
Dim j

rngName = "MyRange"
i = 1

For Each mySheet In Worksheets
rngOnSheet = rngName & i
j = qexc_ProtectAreaOfSheet(mySheet.Name, rngOnSheet, "abc123")
i = i + 1
Next mySheet

MsgBox "Completed."

End Sub

 

[EugeniaP]

Here is the answer:

Sub protectSheets()

Dim mySheet As Worksheet
Dim nomer As Integer
Dim ranTitle As String
nomer = 2


For Each mySheet In Worksheets

ranTitle = "Ran" & nomer

mySheet.Protection.AllowEditRanges.Add Title:=ranTitle,
Range:=mySheet.Range("D1014,D1632,D3435")

mySheet.Protect

nomer = nomer + 1

Next mySheet


End Sub


Thanks for your help!