I have a macro that opens automatically and applies a special sheet protection which allows for grouping and some editing for a specific sheet, Program Data. The macro I have is this:
Private Sub Workbook_Open()
With Worksheets("Program Data")
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True,
AllowInsertingRows:=True
End With
End Sub
Right now this runs as soon as you open the file, but it only applies to Program Data. I don't know how to change the with statement to accommodate the entire workbook without naming the sheets one-by-one. But there are very many sheets, so that's not a good option. How do I do apply this for all sheets in the file?
You can loop through the worksheet objects like this.
Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, _
AllowFormattingColumns:=True, AllowInsertingRows:=True
End With
Next
End Sub
You want a For loop that targets all the sheets. Basically...
Private Sub Workbook_Open()
Dim WS As Worksheet
For Each WS in ThisWorkbook.Worksheets
With WS
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True,
AllowInsertingRows:=True
End With
Next WS
End Sub
Let us know if this helps.
try this
For i = 1 To Worksheets.Count - 1
With Worksheets(i)
.EnableOutlining = True
.Protect UserInterfaceOnly:=True, AllowFiltering:=True, AllowFormattingColumns:=True, AllowInsertingRows:=True
End With
Next
Related
On a protected user form (table with data) I have found a possibility to allow sorting protected cells by unprotecting the header row when selected (if...then) and protecting the sheet whenever another cell(s) is selected (else). So now, when clicking the header row and clicking the filter symbol, users can sort, because in this moment the file is unprotected.
Now, there is one problem remaining: when users select data in the databodyrange (or any other cell that is not in header row (here: row 11)) and then directly click on the filter symbol in the header row for sorting, they have activated cells that cause the sheet to protect (Else) and to unprotect (If...then) at the same time.
So the code itsself works fine. What I struggle with is writing an error handling, that for example on error selects a cell in the header row and continues to run the macro in all funcionality + doesn't disturb the user.
What is an easy Error Handling for the following code?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Ws As Worksheet
Set Ws = Target.Worksheet
If (Target.Row = 11) Then 'Row 11 is the tables header's row
With Ws
.Unprotect ""
End With
Else
With Ws
.EnableAutoFilter = True
.EnableOutlining = True
.Protect "", contents:=True, UserInterfaceonly:=True, AllowFormattingRows:=True, AllowFiltering:=True, AllowSorting:=True
End With
End If
End Sub
Thanks - and really just an error handling is looked for. No other workaround!
I solved my own issue using On Error Resume Next. It is not super elegant, but this way users are able to "sort on a protected sheet with locked cells".
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Ws As Worksheet
Set Ws = Target.Worksheet
On Error Resume Next
If Err.Number <> 0 Then
Application.Undo
MsgBox "Please select a cell in the header row, before sorting or filtering."
End If
If (Target.Row = 11) Then
With Ws
.Unprotect ""
End With
Else
With Ws
.EnableAutoFilter = True
.EnableOutlining = True
.Protect "", contents:=True, UserInterfaceonly:=True, AllowFormattingRows:=True, AllowFiltering:=True, AllowSorting:=True
End With
End If
End Sub
When we have a workbook with several sheets
sheet_1, sheet_2, ..., sheet_n, sheet_constant
and we like to create n workbooks with pairs of two sheets
workbook 1: sheet_1, sheet_constant
workbook 2: sheet_2, sheet_constant
...
workbook n: sheet_n, sheet_constant
how can we do this with vba?
I know we can copy one sheet with this
Sub CopySheet()
ThisWorkbook.Sheets("sheet_1").Copy
Application.Dialogs(xlDialogSaveAs).Show
End Sub
And I tried this with no success
Sub CopySheets()
ThisWorkbook.Sheets("sheet_1").Copy
ThisWorkbook.Sheets("sheet_constant").Copy
Application.Dialogs(xlDialogSaveAs).Show
End Sub
You can use:
Sub CopySheets(VariableSheetName As String, ConstantSheetName As String)
ThisWorkbook.Sheets(Array(VariableSheetName, _
ConstantSheetName)).Copy
Application.Dialogs(xlDialogSaveAs).Show
End Sub
Note: Copying both sheets at once has the advantage that any references between the sheets won't suddenly become links to the original workbook, which is what could happen if you copy the sheets one after the other.
This subroutine can be called as:
CopySheets "sheet_1", "sheet_constant"
CopySheets "sheet_2", "sheet_constant"
CopySheets "sheet_3", "sheet_constant"
or in a loop (assuming your sheets do have numbers in them)
For i = 1 To 3
CopySheets "sheet_" & i, "sheet_constant"
Next
or, if you want all sheets copied:
For Each ws in Worksheets
If ws.Name <> "sheet_constant" Then
CopySheets ws.Name, "sheet_constant"
End If
Next
Based on #YowE3K answer, this one is a little more generic and hase autoSave option.
Sub CopySheets()
Dim ws As Worksheet
ChDir (ThisWorkbook.Path)
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "sheet_constant" Then GoTo NextIteration
ThisWorkbook.Sheets(Array(ws.Name, "sheet_constant")).Copy
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.SaveAs Filename:=ws.Name, FileFormat:=xlNormal, CreateBackup:=False
ActiveWorkbook.Saved = True
ActiveWindow.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
NextIteration:
Next ws
End Sub
Have the following code at the Workbook object level, but it's not allowing for the autofilter or ungrouping of columns.
Private Sub Workbook_Open()
For Each ws In Sheets
With ws
.Protect Password:="xxxxxxxx", Userinterfaceonly:=True,
AllowFormattingColumns:=True, AllowFormattingRows:=True, _
AllowFiltering:=True, AllowInsertingRows:=True,
AllowSorting:=True, AllowDeletingRows:=True
End With
Next ws
End Sub
I cannot lock my sheet because I need to access some cells to run macros.
I want a macro that selects cell (F1) whenever the user try to select any other cell.
I need a macro like this one, I guess:
Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
Put this code in the worksheet module:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Cells(1, 6).Select
End Sub
Like other guys wrote, is better to unprotect the sheet, play your macro and protect the sheet but, if you think that disable all cells, minus the cell that you identify, is the best way, you can use this code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("F10")) Is Nothing Then 'use your free cell
do
Else
Application.Undo
MsgBox "you can modify only the cell(F10)" 'Just to inform what is the cell editable
Range("F10").Select
End If
Application.EnableEvents = True
End Sub
Here are 2 options:
.
1. Without protecting the sheet - in each sheet module to customize "unlocked" cell (Ex. "C3")
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Column <> 3 Or .Row <> 3 Or .CountLarge > 1 Then Application.Undo
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
With Target
If .Column <> 3 Or .Row <> 3 Or .CountLarge > 1 Then Cells(3, 3).Select
End With
Application.EnableEvents = True
End Sub
.
2. Protecting the sheet - in ThisWorkbook module
Private Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
protectWS ws
Next
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
protectWS Sh
End Sub
Public Function protectWS(Optional ByRef ws As Worksheet = Nothing) As Boolean
If ws Is Nothing Then Set ws = Application.ActiveSheet
If Not isWSProtected(ws) Then
ws.Protect Password:=vbNullString, _
DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
UserInterfaceOnly:=True, _
AllowFormattingCells:=False, _
AllowFormattingColumns:=False, _
AllowFormattingRows:=False, _
AllowInsertingColumns:=False, _
AllowInsertingRows:=False, _
AllowInsertingHyperlinks:=False, _
AllowDeletingColumns:=False, _
AllowDeletingRows:=False, _
AllowSorting:=False, _
AllowFiltering:=False, _
AllowUsingPivotTables:=False
End If
End Function
Private Function isWSProtected(Optional ByRef ws As Worksheet = Nothing) As Boolean
isWSProtected = ws.ProtectContents Or _
ws.ProtectDrawingObjects Or _
ws.ProtectScenarios
End Function
Option 1 forces users to cell C3
can be moved to ThisWorkbook module, with parameters for row and column
Option 2 is using an empty password, and allows VBA execution (UserInterfaceOnly)
I have this macro for a button to refresh all the pivot-tables in a worksheet:
Sub Button3_Click()
ThisWorkbook.RefreshAll
End Sub
And I wanted to add the functionality to refresh all the pivot tables even if they are on a protected sheet. I protected the pivot-table sheet with the password MyPwd and used the below code, but it won't work:
Sub Button3_Click()
Unprotect Password:="MyPwd"
ThisWorkbook.RefreshAll
Protect Password:="MyPwd", _
DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowUsingPivotTables:=True
End With
End Sub
Visual Basic is all new to me. What am I doing wrong?
The Unprotect you want is a worksheet method. You should qualify it.
Sub ProtRef()
Dim TargetSht As Worksheet
Set TargetSht = ThisWorkbook.Sheets("Sheet1") 'Modify as needed.
With TargetSht
.Unprotect MyPwd
ThisWorkbook.RefreshAll
.Protect MyPwd
End With
End Sub
Note TargetSht and the With-End With. Let us know if this helps.
EDIT:
Sub ProtRef()
Dim WB As Workbook, WS As Worksheet
For Each WS In WB.Worksheets
If WS.Name <> "Sheet1" Then
WS.Unprotect MyPwd
End If
End With
ThisWorkbook.RefreshAll
For Each WS In WB.Worksheets
If WS.Name <> "Sheet1" Then
WS.Protect MyPwd
End If
End With
End Sub
Paste in a regular module, like below:
Let us know if this helps.
Thank you #BK201 for having a crack at it, you definitely pointed me in the right direction. I used this code in the button and it seemed to do the trick:
Sub Button1_Click()
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
Sht.Unprotect Password:="MyPwd"
ThisWorkbook.RefreshAll
Next
For Each Sht In ThisWorkbook.Worksheets
Sht.Protect Password:="MyPwd"
Next
End Sub