I have a workbook with VBA code which copies a template sheet but I want to protect certain cells from editing when copied. The template sheet is protected by the locked cells which needs to be locked, but some cells are for user input and should be unlocked.
I cant get it to lock the cells in the copied sheet.
Sub MyCopySheet()
Dim myNewSheetName
myNewSheetName = InputBox("Enter Today's Date")
Worksheets.Add(After:=Worksheets("Home")).Name = myNewSheetName
Sheets(Sheets.Count - 1).Activate
Cells.Copy
Sheets(myNewSheetName).Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("F5:F69").ClearContents
Range("G5:G69").ClearContents
Range("H5:H69").ClearContents
Range("I5:I69").ClearContents
Range("J5:J69").ClearContents
Range("K5:K69").ClearContents
Range("Q5:Q59").ClearContents
Range("O5:O59").ClearContents
Range("L5:L69").ClearContents
Range("B23:B27").ClearContents
Range("B59:B63").ClearContents
Range("B32:B36").ClearContents
Range("B78:B94").ClearContents
Range("C78:C94").ClearContents
Range("F78:F94").ClearContents
Range("G78:G94").ClearContents
Range("J78:J94").ClearContents
Range("I78:I94").ClearContents
Range("K78:K94").ClearContents
Range("L78:L94").ClearContents
Range("B50:B54").ClearContents
End Sub
Sub lockcells()
Dim Rng
Dim MyCell
Set Rng = Range("A1:Q96")
For Each MyCell In Rng
If MyCell.Value = "" Then
Else: ActiveSheet.Unprotect Password:="password"
MyCell.Locked = True
MyCell.FormulaHidden = False
ActiveSheet.Protect Password:="password", UserInterFaceOnly:=True
End If
Next
End Sub
Basically all the cells with Range().ClearContent must be unlocked and the rest locked.
Sub MyCopySheet()
Dim myNewSheetName
myNewSheetName = InputBox("Enter Today's Date")
Worksheets.Add(After:=Worksheets("Home")).Name = myNewSheetName
Sheets(Sheets.Count - 1).Activate
Cells.Copy
Sheets(myNewSheetName).Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'clear contents
Range("P107,B23:B27,B32:B36,B50:B54,B59:B63,B78:C94,F78:G94,I78:L94,O5:O59,Q5:Q59,F5:L69").ClearContents
End Sub
I reduced your code to clear contents. And below, the code to unprotect cells from range where you cleared contents
Sub lockcells()
Dim Rng
Dim MyCell
Set Rng = Range("A1:Q96")
For Each MyCell In Rng
If MyCell.Value = "" Then
Else: ActiveSheet.Unprotect Password:="password"
MyCell.Locked = True
MyCell.FormulaHidden = False
ActiveSheet.Protect Password:="password", UserInterFaceOnly:=True
End If
Next
'now we unprotect the range we cleared contents
Range("P107,B23:B27,B32:B36,B50:B54,B59:B63,B78:C94,F78:G94,I78:L94,O5:O59,Q5:Q59,F5:L69").Locked = False
End Sub
Related
I need some help to upgrade my VBA code.
I try to find a code which will unlock a specific row based on the current date. The problem is, I don't want all the row's cells to be unlocked but only a set of specific range. Like on the current date which are in the column "B", the cells unlocked will be from ("D" to "K"); ("M" to "P"); ("R"to"S") and ("U"to"V").
The cells in-between contain formulas that I don't want people to mess up or change by mistake.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("B" & Selection.Row).Value <> Date Then
ActiveSheet.Protect Password:="3827"
MsgBox "Only today's date needs to be edited!", vbInformation, "REMINDER"
ElseIf Range("B" & Selection.Row).Value = Date Then
ActiveSheet.Unprotect Password:="3827"
ActiveSheet.EnableSelection = xlNoRestrictions
End If
End Sub
Why not take it a step further? Only let them select the row of Today's date of those columns when the worksheet is activated!
Option Explicit
Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D:K,M:P,R:S,U:V"
Private Sub Worksheet_Activate()
Dim dToday As Date, oRng As Range, oItem As Variant
dToday = Date
With ActiveSheet
.Unprotect Password:=PWD
.Cells.Locked = True
' Look for row with today's date and unlock the row inside usedrange
Set oRng = .Columns("B").Find(What:=dToday)
If Not oRng Is Nothing Then
For Each oItem In Split(UNLOCK_COLS, ",")
Intersect(oRng.EntireRow, .Columns(oItem)).Locked = False
Next
End If
.Protect Password:=PWD
.EnableSelection = xlUnlockedCells
End With
End Sub
With optimisation sugguestion from Tim Williams, you can even skip the loop:
Option Explicit
Private Const PWD As String = "3827"
Private Const UNLOCK_COLS As String = "D1:K1,M1:P1,R1:S1,U1:V1"
Private Sub Worksheet_Activate()
Dim dToday As Date, oRng As Range
dToday = Date
With ActiveSheet
.Unprotect Password:=PWD
.Cells.Locked = True
' Look for row with today's date and unlock the specific columns in the row
Set oRng = .Columns("B").Find(What:=dToday)
If Not oRng Is Nothing Then oRng.EntireRow.Range(UNLOCK_COLS).Locked = False
.Protect Password:=PWD DrawingObjects:=False, Contents:=True, Scenarios:=True ' This allows Adding comments
.EnableSelection = xlUnlockedCells
End With
End Sub
I am (trying) creating a VBA code that filters Sheet1 based on the inputted password. I have an excel file with 2 Sheets and sheet2 has the passwords in Column B and the "filter" in column A. I will distribute the excel file and give the corresponding password to the parties and when they input their password all the info from other parties will be deleted.
The code:
Sub Open_with_password()
pas = Application.InputBox("Input password")
If pas = False Or pas = "" Then Exit Sub
Application.ScreenUpdating = False
a = 0
For i = 1 To Sheet2.Range("A1").End(xlDown).Row
If Worksheets("Sheet2").Cells(i, 2) = pas Then
c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password
a = a + 1
End If
Next
'Check for password
If a = 0 Then
MsgBox "Wrong password. Report can not be accessed"
ActiveWorkbook.Close False
Sheet2.Visible = xlSheetVeryHidden
Sheet1.Visible = xlSheetVeryHidden
Exit Sub
'If correct password
Else:
Sheet1.Visible = xlSheetVisible
Worksheets("Sheet1").Select
Worksheets("Sheet1").Unprotect Password = "XYZ"
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'Filter according to input password
If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c
Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1)
Rows(rCell.Row).Select
Range(Selection, Selection.End(xlDown)).Copy
Worksheets("Sheet1").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A2").Select
'If Admin
If c = "Admin" Then
Sheet2.Visible = xlSheetVisible
Sheet1.Visible = xlSheetVisible
End If
End If
Application.ScreenUpdating = True
End Sub
The issues I've encountered so far are:
1. When I open the file, the input box doesn't automatically show, ideally it would show while the user sees nothing.
2. When it filters according to the password (The filter works) when it reaches the part where it's suppose to delete everything else, it doesn't. I am using a copy and paste method and an error pops (Error 1004)
Much appreciated for your help
Suggestions:
When the workbook opens call your macro.
Private Sub Workbook_Open()
Open_with_password
End Sub
I would keep your data intact on a hidden worksheet.
Sheet1.Visible = xlSheetVeryHidden
Copy the filtered cells to a different worksheet
Set rCell = ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
rcell.Copy Sheet2.Range("A1")
When the workbook closes clear Sheet2.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheet2.Cells.ClearContents
End Sub
If you do it this way you users won't be able to access the hidden data when they open the workbook without enabling macros.
1.Code should be on the Workbook_Open() event, you may do a call for another sub -my suggestion-. In "ThisWorkbook" object:
Private Sub Workbook_Open()
Call Open_with_password
End Sub
2. If you are using copy-paste, you can't do a select in the middle, doing so will lost the clipboard (normal behavior in excel VBA), hence you will having nothing to paste for, thus the error.
Rows(rCell.Row).Select
Range(Selection, Selection.End(xlDown)).Copy
Worksheets("Sheet1").Select
Range("A2").Select 'lost clipboard
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A2").Select
Change for
Rows(rCell.Row).Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Sheet1").Range("A2").PasteSpecial Paste:=xlPasteValues
Excel.Application.CutCopyMode = False 'clears clipboard
EDIT:
It should work no matter if there are filters or not.
OT: Next step for you would be searching how to avoid select (this is so much time consuming).
I am answering my own question as I used the following solution and it seems to be working:
Private Sub Workbook_Open()
Call Open_with_password
End Sub
&
Sub Open_with_password()
Sheet2.Visible = xlSheetHidden
Sheet1.Visible = xlSheetHidden
Sheet3.Cells.ClearContents
Sheet1.Range("A1", "AQ1").Copy
Sheet3.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = False
pas = Application.InputBox("Input password")
If pas = False Or pas = "" Then Exit Sub
a = 0
For i = 1 To Sheet2.Range("A1").End(xlDown).Row
If Worksheets("Sheet2").Cells(i, 2) = pas Then
c = Worksheets("Sheet2").Cells(i, 1) 'the agency corresponding with the password
a = a + 1
End If
Next
'Check for password
If a = 0 Then
MsgBox "Wrong password. Report can not be accessed"
ActiveWorkbook.Close False
Sheet2.Visible = xlSheetVeryHidden
Sheet1.Visible = xlSheetVeryHidden
Exit Sub
'If correct password
Else:
Sheet1.Visible = xlSheetVisible
Worksheets("Sheet1").Select
Worksheets("Sheet1").Unprotect Password = "amazon"
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'Filter according to input password
If c <> "Admin" Then ActiveSheet.Range("$A$2:$AQ$500000").AutoFilter Field:=17, Criteria1:=c
Set rCell = ActiveSheet.AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1)
Rows(rCell.Row).Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Sheet3").Range("A2").PasteSpecial Paste:=xlPasteValues
Excel.Application.CutCopyMode = False 'clears clipboard
Sheet1.Visible = xlSheetVeryHidden
'If Admin
If c = "Admin" Then
Sheet2.Visible = xlSheetVisible
Sheet1.Visible = xlSheetVisible
End If
End If
Application.ScreenUpdating = True
End Sub
This code makes the entire sheet read only.
I want to make cells which are empty (hold null value) read only. It should work for different Excel files where the used cell range could be different.
Sub proFirst()
Sheets("DCAFTE").UsedRange.Select
ActiveSheet.Unprotect
ActiveWorkbook.Unprotect
Dim myRange As Range
Set myRange = ActiveSheet.UsedRange
myRange.Select
Selection.Locked = True
ActiveSheet.Protect Contents:=True
End Sub
You can replace your code with the below code. This will select only the cells which are empty (blank) and make it read only. The cells which are having values will be editable.
Sub proFirst()
Sheets("DCAFTE").Select
ActiveSheet.Unprotect
ActiveWorkbook.Unprotect
Dim myCell As Range
Set myCell = Selection
Cells.Select
Selection.Locked = False
myCell.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Locked = True
ActiveSheet.Protect Contents:=True
myCell.Select
End Sub
I have a macro that copy/pastes a selection from one worksheet (Sheet1), to another worksheet (Notes). It works well. Now I want to first check if that worksheet exists. If it does not exist, I want to create it, then continue with the copy/pasting the selection.
When the "Notes" worksheet exists, the copy/paste works fine.
If the worksheet does not exist, it creates it, but the paste operation doesn't work. I don't get any errors. I have to rerun the macro and then the paste works (since the worksheet has already been created). Any ideas on what I missed?
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
When you do the Add, the activesheet becomes the new worksheet and your previous Selection is lost...............you must "remember" it before the Add:
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
Dim RtoCopy As Range
Set RtoCopy = Selection
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
RtoCopy.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Pay attention to the three lines referencing RtoCopy .
You have On Error Resume Next in your code. First time through it goes on its merry way. The second time through the Error check triggers the creation of the new tab.
On Error Resume Next is bad. Don't use it.
See this question for more information on solving your problem How to check whether certain sheets exist or not in Excel-VBA?
You should first activate and select the sheet and range to be copied. This works.
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Worksheets("Sheet1").Activate 'Activete "Sheet1"
Worksheets("Sheet1").Range("A1").Select 'Select the range to be copied
'Then copy selection
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
I suggest using Function for more re-usability:
A dirty and fast way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
Set ws = Sheets(wsName)
isWorksheetValid = True
Exit Function
ErrHndl:
isWorksheetValid = False
End Function
A correct but a bit slower way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
For Each ws in Sheets
If (UCASE(ws.Name) = UCASE(wsName)) Then
isWorksheetValid = True
Exit Function
End If
Next
ErrHndl:
isWorksheetValid = False
End Function
Now you need just use it like this:
If (isWorksheetValid(mySheetName) Then
' Add your code here
End If
I am trying to write a macro that will lock any cell greater than 0. When I run the code below it works but locks the 1st row where I have a drop down arrow that does sorting and number filters. Is there a way to add to this code so that the first row wont be locked?
Sub Test()
Dim Cell As Range
Dim MyPlage As Range
With ThisWorkbook.ActiveSheet
.Unprotect
.Cells.Locked = False
Set MyPlage = .Range("J2:AA1074")
For Each Cell In MyPlage
If Not IsError(Cell) Then
If Cell.Value > "0" Then
Cell.Locked = True
End If
End If
Next
.Protect
End With
End Sub
The most simplest was is to define your range which doesn't include the Top Row :)
Change
.Range("J2:AA1074")
to
.Range("J3:AA1074")
Also, Instead of looping through every cell in the range and checking if that cell has an error or not, you can directly use SpecialCells. For example (TRIED AND TESTED)
Sub Sample()
Dim Cell As Range, MyPlage As Range, FinalRange As Range
With ThisWorkbook.ActiveSheet
.Unprotect
.Cells.Locked = False
On Error Resume Next
Set MyPlage = .Range("J3:AA1074").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not MyPlage Is Nothing Then
For Each Cell In MyPlage
If Cell.Value > 0 Then Cell.Locked = True
Next
End If
.Protect DrawingObjects:=True, _
Contents:=True, _
Scenarios:=True, _
AllowFiltering:=True, _
AllowSorting:=True
.EnableSelection = xlUnlockedCells
End With
End Sub
To ensure that Autofilter and Sorting works, specify it in .Protect as I have done above.
Before you run the above code, you also need to take one extra step.
Unprotect the worksheet if it is already protected
Under Review Tab, click on "Allow Users to Edit Ranges"
Add "New" range
Select the range you want allow users to sort
Screenshot
You can add following code to the Sheet module (change Range("J1:AA1") to the range with your autofilter):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.Intersect(Target, Range("J1:AA1")) Is Nothing Then
ActiveSheet.Protect
Else
ActiveSheet.Unprotect
End If
End Sub