Help! In VBA, how do I add in protect sheet options into my coding

M

MISS_AJAZ

New Member
Joined
Jun 23, 2014
Messages
17
Hi all,

Need some help please.
The macro I have created currently creates a new sheet from a current one (copies it exactly and then changes a few things in the sheet as per what I have asked it to do). The macro is currently working fine and does what I want it to do, however I've noticed that it's not copying over the worksheet protection options from the original, i.e. allow users to: Format cells, format columns, format rows...etc...

After searching the forums I have found this:

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True

I tried inserting it into my current one but it's not working. The current one is this (without the above inserted):

Sub CreateProductionSampleSpec()
'
' Macro5 Macro
'


'
Application.ScreenUpdating = False
ThisWorkbook.Unprotect Password:="password"


ActiveSheet.CheckBoxes.Add(869.25, 131.25, 15, 15.75).Select
Sheets("GRADED SIZE SPEC").Copy Before:=Sheets(12)
Sheets("GRADED SIZE SPEC (2)").Select
Sheets("GRADED SIZE SPEC (2)").Name = "PRODUCTION SAMPLES"
Sheets("PRODUCTION SAMPLES").Select
With ActiveWorkbook.Sheets("PRODUCTION SAMPLES").Tab
.Color = 65535
.TintAndShade = 0
End With
ActiveSheet.Unprotect Password:="password"
Range("C2:S2").Select
ActiveCell.FormulaR1C1 = "PRODUCTION SAMPLES"
Range("M7:S7").Select
ActiveSheet.Shapes.Range(Array("Check Box 1")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 5")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 4")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 3")).Select
Selection.Delete
Range("Q8:S8").Select
Selection.ClearContents
Range("J8:P8").Select
Selection.ClearContents
Range("J8:S8").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("T4:Z4").Select
Selection.Copy Destination:=Range("J8:P8")
Range("P8").Select
Selection.AutoFill Destination:=Range("P8:S8"), Type:=xlFillDefault
Range("P8:S8").Select
Range("J5:S7").Select
Range("M7").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("M7:S7").Select
Selection.ClearContents
Columns("T:Z").Select
Selection.EntireColumn.Hidden = True
Range("M7:S7").Select
ActiveWindow.SmallScroll Down:=-21


ActiveSheet.Protect Password:="password"
ThisWorkbook.Protect Password:="password"
Application.ScreenUpdating = True


End Sub



Can someone please help :)

Thank you
Nisha
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Code: 
Sub CreateProductionSampleSpec()'
' Macro5 Macro
'
Dim ws As Worksheet


'
Application.ScreenUpdating = False
ThisWorkbook.Unprotect Password:="password"




ActiveSheet.CheckBoxes.Add(869.25, 131.25, 15, 15.75).Select
Sheets("GRADED SIZE SPEC").Copy Before:=Sheets(12)
Sheets("GRADED SIZE SPEC (2)").Select
Sheets("GRADED SIZE SPEC (2)").Name = "PRODUCTION SAMPLES"
Sheets("PRODUCTION SAMPLES").Select
With ActiveWorkbook.Sheets("PRODUCTION SAMPLES").Tab
.Color = 65535
.TintAndShade = 0
End With
ActiveSheet.Unprotect Password:="password"
Range("C2:S2").Select
ActiveCell.FormulaR1C1 = "PRODUCTION SAMPLES"
Range("M7:S7").Select
ActiveSheet.Shapes.Range(Array("Check Box 1")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 5")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 4")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 3")).Select
Selection.Delete
Range("Q8:S8").Select
Selection.ClearContents
Range("J8:P8").Select
Selection.ClearContents
Range("J8:S8").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("T4:Z4").Select
Selection.Copy Destination:=Range("J8:P8")
Range("P8").Select
Selection.AutoFill Destination:=Range("P8:S8"), Type:=xlFillDefault
Range("P8:S8").Select
Range("J5:S7").Select
Range("M7").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("M7:S7").Select
Selection.ClearContents
Columns("T:Z").Select
Selection.EntireColumn.Hidden = True
Range("M7:S7").Select
ActiveWindow.SmallScroll Down:=-21


[COLOR=#ff0000]For Each ws In ActiveWorkbook.Worksheets[/COLOR]
[COLOR=#ff0000]    With ws[/COLOR]
[COLOR=#ff0000]    ws.Activate[/COLOR]
[COLOR=#ff0000]    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True _[/COLOR]
[COLOR=#ff0000]    , AllowFormattingCells:=True, AllowFormattingColumns:=True, _[/COLOR]
[COLOR=#ff0000]    AllowFormattingRows:=True[/COLOR]
[COLOR=#ff0000]    End With[/COLOR]
[COLOR=#ff0000]Next ws[/COLOR]


ThisWorkbook.Protect Password:="password"
Application.ScreenUpdating = True


End Sub

The code in red will protect all worksheet in the workbook. This same type of code can be used any other time you want to do the same thing to multiple sheets.

I hope this answers your questions.
 
Upvote 0
Thank you for the quick response!
Okay I have two problems with that code..

1. I need it to also contain: Allow...'Edit scenarios' and 'Edit objects'. I'm trying to add them in but messing it up somehow:(

2. After creating that worksheet it seems to be jumping to the end worksheet. I want it to stay on this worksheet (the one that the macro created).

Thank you
 
Upvote 0
MISS_AJAZ said:
Thank you for the quick response!
Okay I have two problems with that code..

1. I need it to also contain: Allow...'Edit scenarios' and 'Edit objects'. I'm trying to add them in but messing it up somehow:(

2. After creating that worksheet it seems to be jumping to the end worksheet. I want it to stay on this worksheet (the one that the macro created).

Thank you
Click to expand...

1. I just copied all the protect variables from your original post... To change the objects and scenarios you just have to change them from true to false.

2. In order to protect every sheet you have to activate every sheet one by one in VBA. (That is why the last sheet is always selected). Since that is a problem it is simple to create another variable to set the original worksheet as x then select x at the end of the code.

Code: 
Sub CreateProductionSampleSpec() '
' Macro5 Macro
'
Dim ws As Worksheet
Dim x As Worksheet


Application.ScreenUpdating = False
ThisWorkbook.Unprotect Password:="password"


Set x = ActiveSheet


ActiveSheet.CheckBoxes.Add(869.25, 131.25, 15, 15.75).Select
Sheets("GRADED SIZE SPEC").Copy Before:=Sheets(12)
Sheets("GRADED SIZE SPEC (2)").Select
Sheets("GRADED SIZE SPEC (2)").Name = "PRODUCTION SAMPLES"
Sheets("PRODUCTION SAMPLES").Select
With ActiveWorkbook.Sheets("PRODUCTION SAMPLES").Tab
.Color = 65535
.TintAndShade = 0
End With
ActiveSheet.Unprotect Password:="password"
Range("C2:S2").Select
ActiveCell.FormulaR1C1 = "PRODUCTION SAMPLES"
Range("M7:S7").Select
ActiveSheet.Shapes.Range(Array("Check Box 1")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 5")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 4")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("TextBox 3")).Select
Selection.Delete
Range("Q8:S8").Select
Selection.ClearContents
Range("J8:P8").Select
Selection.ClearContents
Range("J8:S8").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.UnMerge
Range("T4:Z4").Select
Selection.Copy Destination:=Range("J8:P8")
Range("P8").Select
Selection.AutoFill Destination:=Range("P8:S8"), Type:=xlFillDefault
Range("P8:S8").Select
Range("J5:S7").Select
Range("M7").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("M7:S7").Select
Selection.ClearContents
Columns("T:Z").Select
Selection.EntireColumn.Hidden = True
Range("M7:S7").Select
ActiveWindow.SmallScroll Down:=-21




For Each ws In ActiveWorkbook.Worksheets
    With ws
    ws.Activate
    ActiveSheet.Protect Password:="password", DrawingObjects:=False, Contents:=True, Scenarios:=False _
    , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
    AllowFormattingRows:=True
    End With
Next ws


x.Select
ThisWorkbook.Protect Password:="password"
Application.ScreenUpdating = True




End Sub

I hope this code does what you need.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
332
RoryA
RoryA
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
188
6StringJazzer
6StringJazzer
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
862
kerm007
K
J
  • Question
Issue with Macros and renaming files
Replies
6
Views
501
kevin9999
K
J
  • Question
VBA Code to Add Rows is slowing down
Replies
5
Views
512
JayB0730
J

Forum statistics

Threads
1,214,990
Messages
6,122,626
Members
449,094
Latest member
bsb1122

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