Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Row = 1 Then Exit Sub
If .Column = 1 Then Call ApplyRule(Target)
End With
End Sub
Option Explicit
Public Const MyRange = "A2:A5000"
Public Const MySheet = "[COLOR=#ff0000]Sheet1[/COLOR]" '[COLOR=#ff0000][I]amend to corrrect sheet name[/I][/COLOR]
Public Const SheetPassword = "[COLOR=#ff0000]password[/COLOR]" '[COLOR=#ff0000][I]amend to your password[/I][/COLOR]
Sub How_to_call_the_sub()
Call ApplyRule(Sheets(MySheet).Range(MyRange))
End Sub
Sub ApplyRule(aRange As Range)
Dim Cell As Range, ws As Worksheet
Set ws = aRange.Parent
ws.Unprotect SheetPassword
aRange.EntireRow.Locked = False
For Each Cell In aRange
If Cell = True Then Cell.Offset(, 5).Resize(, 5).Locked = True
Next Cell
ws.Protect SheetPassword
End Sub
Function MandatoryCells() As Boolean
Dim Rng As Range, Cell As Range
For Each Cell In Sheets(MySheet).Range(MyRange)
If Cell Then
If WorksheetFunction.CountBlank(Cell.Offset(, 1).Resize(, 4)) > 0 Then
MandatoryCells = False
Exit Function
End If
End If
Next Cell
MandatoryCells = True
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not MandatoryCells Then
MsgBox "Request to close denied - mandatory cells not completed", vbCritical, "Cannot close"
Cancel = True
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Not MandatoryCells Then MsgBox "Some mandatory cells incomplete", vbInformation, "Workbook saved"
End Sub
Yes, should be A2 to last row
HeaderA HeaderB HeaderC HeaderD HeaderE HeaderF HeaderG HeaderH HeaderI HeaderJ True D D D D D Move D D D D D False True
<colgroup><col width="64" span="10" style="width:48pt"> </colgroup><tbody>
</tbody>