I have a QC form that contains merged cells, I am not allowed to change the form. I need to lock the cells after data entry when saving, I have the following...
Option ExplicitPrivate Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim i As Long Dim j As Long Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayAlerts = False If ActiveSheet.Name = "Sheet1" Then 'change name of sheet as needed 'Resume to next line if any error occurs On Error Resume Next Dim Cell As Range With ActiveSheet 'First of all unprotect the entire sheet .Unprotect Password:="" 'Now search for non blank cells and lock them and unlock blank cells For Each Cell In ActiveSheet.UsedRange i = Cell.Row j = Cell.Column If Cell.Value <> "" Then If Cell.Locked = False Then Cell.Locked = True End If End If Next Cell 'Protect with blank password, you can change it .Protect Password:="" End With Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True Application.ScreenUpdating = True End If End Sub
In the attached file I have highlighted the cells that would require input, the highlights will return to "no fill" once the form is working.
Password is blank for now.
Thanks in advance for your help,