VBA to lock cell(s) if one cell is used and unlock others if another cell is used.

S

SteynBS

Board Regular
Joined
Jun 27, 2022
Messages
111
Office Version
  1. 365
Platform
  1. Windows
Hi Guys,

Need some help with a VBA. I have a sheet with 7 columns A:G. multiple rows will be used. I need only certain cells unprotected when specific cell is used. and when another cell is used other cells should be locked and others unprotected. Below scenarios will apply, but only one instance of the scenario at a time. If the user uses the 1st scenario that will be the only scenario used on the spreadsheet. if the 2nd scenario is used. only the second scenario will be used for the whole sheet.

Scenarios

If Column C has an "X" only 3 columns should be allowed to be used Columns A,B and D and be made compulsory. The others locked for all rows.
1713434026456.png


If Column G has an "X" only 2 Columns should be used and compulsory Columns A and B, the others should be locked.
1713434098564.png


If Column F is used only column A should be used and be compulsory. All others should be locked for all rows
1713434155731.png


If Column E is used only columns A and B should be used and be made compulsory. All others should be blocked for all rows
1713434194889.png
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Change the password (two occurrences in red) to suit your needs. Run the macro after you have entered all your data on an unprotected sheet. Keep in mind that after you run the macro, the sheet will be protected using the password you enter in the code and only the appropriate cells will be unlocked. Also, the macro will force entry into the compulsory cells if they are empty.
Rich (BB code): 
Sub LockUnlockCells()
    Application.ScreenUpdating = False
    Dim fnd As Range, rng As Range, rng2 As Range, lRow As Long, srcRng As Range, response As String
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Sheets("Sheet1")
        Set fnd = .UsedRange.Find("X", LookIn:=xlValues, lookat:=xlWhole)
        .Unprotect Password:="pw"
        .Cells.Locked = True
    End With
    If Not fnd Is Nothing Then
        Select Case fnd.Column
            Case Is = 3
                For Each rng In Range("C2:C" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row), Range("D" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 3 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
            Case Is = 5
                For Each rng In Range("E2:E" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 2 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
            Case Is = 6
                For Each rng In Range("F2:F" & lRow)
                    If rng = "X" Then
                        Range("A" & rng.Row).Locked = False
                        If Range("A" & rng.Row) = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & Range("A" & rng.Row).Address(0, 0) & ".")
                                If response <> "" Then
                                    Range("A" & rng.Row) = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & Range("A" & rng.Row).Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    End If
                Next rng
            Case Is = 7
                For Each rng In Range("G2:G" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 2 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
        End Select
    End If
    With Sheets("Sheet1")
        .Protect Password:="pw"
        .EnableSelection = xlUnlockedCells
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Change the password (two occurrences in red) to suit your needs. Run the macro after you have entered all your data on an unprotected sheet. Keep in mind that after you run the macro, the sheet will be protected using the password you enter in the code and only the appropriate cells will be unlocked. Also, the macro will force entry into the compulsory cells if they are empty.
Rich (BB code): 
Sub LockUnlockCells()
    Application.ScreenUpdating = False
    Dim fnd As Range, rng As Range, rng2 As Range, lRow As Long, srcRng As Range, response As String
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Sheets("Sheet1")
        Set fnd = .UsedRange.Find("X", LookIn:=xlValues, lookat:=xlWhole)
        .Unprotect Password:="pw"
        .Cells.Locked = True
    End With
    If Not fnd Is Nothing Then
        Select Case fnd.Column
            Case Is = 3
                For Each rng In Range("C2:C" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row), Range("D" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 3 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
            Case Is = 5
                For Each rng In Range("E2:E" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 2 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
            Case Is = 6
                For Each rng In Range("F2:F" & lRow)
                    If rng = "X" Then
                        Range("A" & rng.Row).Locked = False
                        If Range("A" & rng.Row) = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & Range("A" & rng.Row).Address(0, 0) & ".")
                                If response <> "" Then
                                    Range("A" & rng.Row) = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & Range("A" & rng.Row).Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    End If
                Next rng
            Case Is = 7
                For Each rng In Range("G2:G" & lRow)
                    If rng = "X" Then
                        Set srcRng = Union(Range("A" & rng.Row), Range("B" & rng.Row))
                        srcRng.Locked = False
                        If WorksheetFunction.CountA(srcRng) < 2 Then
                            For Each rng2 In srcRng
                                If rng2 = "" Then
                                    Do
                                        response = InputBox("Please enter a value for cell: " & rng2.Address(0, 0) & ".")
                                        If response <> "" Then
                                            rng2 = response
                                            Exit Do
                                        ElseIf response = "" Then
                                            MsgBox "You must enter a value for cell: " & rng2.Address(0, 0) & ".", vbOKOnly, ""
                                        End If
                                    Loop
                                End If
                            Next rng2
                        End If
                    End If
                Next rng
        End Select
    End If
    With Sheets("Sheet1")
        .Protect Password:="pw"
        .EnableSelection = xlUnlockedCells
    End With
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you very much for your assistance. My apologies. I neglected to say that the indicating fields in the scenario once ticked should then lock the other cells not applicable to that scenario. We want to limit the potential mistakes users can make before the rest of the document can be populated.

For example. if column C is ticked with an X. The user can from there only fill in Columns A,B and D.

If Column G is ticked like in scenario 2, from there only Columns A and B should be available.
 
Upvote 0
Are you saying that columns A, B and D must be filled in on placing an X in column C? I'm not sure if you want the action to happen automatically when you place an X in column C or if you want to manually run the macro.
 
Upvote 0
mumps said:
Are you saying that columns A, B and D must be filled in on placing an X in column C? I'm not sure if you want the action to happen automatically when you place an X in column C or if you want to manually run the macro.
Click to expand...
Hello,

Yes that is correct, and if that can happen automatically it will be first prize yes.
 
Upvote 0
Start with an unprotected sheet so that users can enter their data. Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Type an uppercase "X" in column C, E, F or G and press the ENTER key. Since the macro is automatically triggered by the entry of the uppercase "X", I would suggest that users first enter the data in the appropriate compulsory cells and lastly type an uppercase "X" in the appropriate column. This will limit the number of warnings if any compulsory cell is unexpectedly left blank.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("C:C,E:E,F:G")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim srcRng As Range, rng As Range
    With Sheets("Sheet1")
        .Unprotect Password:="pw"
        .Cells.Locked = True
    End With
    Select Case Target.Column
        Case Is = 3
            If Target = "X" Then
                Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row), Range("D" & Target.Row))
                srcRng.Locked = False
                If WorksheetFunction.CountA(srcRng) < 3 Then
                    For Each rng In srcRng
                        If rng = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                If response <> "" Then
                                    rng = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    Next rng
                End If
            End If
        Case Is = 5
            If Target = "X" Then
                Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row))
                srcRng.Locked = False
                If WorksheetFunction.CountA(srcRng) < 2 Then
                    For Each rng In srcRng
                        If rng = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                If response <> "" Then
                                    rng = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    Next rng
                End If
            End If
            Case Is = 6
                If Target = "X" Then
                    Range("A" & Target.Row).Locked = False
                    If Range("A" & Target.Row) = "" Then
                        Do
                            response = InputBox("Please enter a value for cell: " & Range("A" & Target.Row).Address(0, 0) & ".")
                            If response <> "" Then
                                Range("A" & Target.Row) = response
                                Exit Do
                            ElseIf response = "" Then
                                MsgBox "You must enter a value for cell: " & Range("A" & Target.Row).Address(0, 0) & ".", vbOKOnly, ""
                            End If
                        Loop
                    End If
                End If
            Case Is = 7
                If Target = "X" Then
                    Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row))
                    srcRng.Locked = False
                    If WorksheetFunction.CountA(srcRng) < 2 Then
                        For Each rng In srcRng
                            If rng = "" Then
                                Do
                                    response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                    If response <> "" Then
                                        rng = response
                                        Exit Do
                                    ElseIf response = "" Then
                                        MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                    End If
                                Loop
                            End If
                        Next rng
                    End If
                End If
    End Select
    With Sheets("Sheet1")
        .Protect Password:="pw"
        .EnableSelection = xlUnlockedCells
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
Start with an unprotected sheet so that users can enter their data. Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Type an uppercase "X" in column C, E, F or G and press the ENTER key. Since the macro is automatically triggered by the entry of the uppercase "X", I would suggest that users first enter the data in the appropriate compulsory cells and lastly type an uppercase "X" in the appropriate column. This will limit the number of warnings if any compulsory cell is unexpectedly left blank.
Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("C:C,E:E,F:G")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim srcRng As Range, rng As Range
    With Sheets("Sheet1")
        .Unprotect Password:="pw"
        .Cells.Locked = True
    End With
    Select Case Target.Column
        Case Is = 3
            If Target = "X" Then
                Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row), Range("D" & Target.Row))
                srcRng.Locked = False
                If WorksheetFunction.CountA(srcRng) < 3 Then
                    For Each rng In srcRng
                        If rng = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                If response <> "" Then
                                    rng = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    Next rng
                End If
            End If
        Case Is = 5
            If Target = "X" Then
                Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row))
                srcRng.Locked = False
                If WorksheetFunction.CountA(srcRng) < 2 Then
                    For Each rng In srcRng
                        If rng = "" Then
                            Do
                                response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                If response <> "" Then
                                    rng = response
                                    Exit Do
                                ElseIf response = "" Then
                                    MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                End If
                            Loop
                        End If
                    Next rng
                End If
            End If
            Case Is = 6
                If Target = "X" Then
                    Range("A" & Target.Row).Locked = False
                    If Range("A" & Target.Row) = "" Then
                        Do
                            response = InputBox("Please enter a value for cell: " & Range("A" & Target.Row).Address(0, 0) & ".")
                            If response <> "" Then
                                Range("A" & Target.Row) = response
                                Exit Do
                            ElseIf response = "" Then
                                MsgBox "You must enter a value for cell: " & Range("A" & Target.Row).Address(0, 0) & ".", vbOKOnly, ""
                            End If
                        Loop
                    End If
                End If
            Case Is = 7
                If Target = "X" Then
                    Set srcRng = Union(Range("A" & Target.Row), Range("B" & Target.Row))
                    srcRng.Locked = False
                    If WorksheetFunction.CountA(srcRng) < 2 Then
                        For Each rng In srcRng
                            If rng = "" Then
                                Do
                                    response = InputBox("Please enter a value for cell: " & rng.Address(0, 0) & ".")
                                    If response <> "" Then
                                        rng = response
                                        Exit Do
                                    ElseIf response = "" Then
                                        MsgBox "You must enter a value for cell: " & rng.Address(0, 0) & ".", vbOKOnly, ""
                                    End If
                                Loop
                            End If
                        Next rng
                    End If
                End If
    End Select
    With Sheets("Sheet1")
        .Protect Password:="pw"
        .EnableSelection = xlUnlockedCells
    End With
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you very much for your assistance.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
Copy paste from one Excel workbook to another with same sheet names and update dates in range
Replies
8
Views
476
Skiier89
S
M
  • Question Question
Formula Calculation is Inadvertently Switching from Automatic to Manual...
Replies
0
Views
152
MNexcelguy19
M
B
  • Question Question
Closest Match in a Range
Replies
1
Views
200
Rijnsent
Rijnsent
N
  • Question Question
VBA - Intersect code being re-initiated
Replies
1
Views
182
Peter_SSs
Peter_SSs
Y
  • Question Question
Custom data validation that locks the cell as per the value in the other cell.
Replies
1
Views
245
Fluff
Fluff

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

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