unlock one row at a time.

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
87
Office Version
  1. 365
Platform
  1. Windows
I wish I didn't have to rely so much on others for help. Fortunately the people here have been great with helping me with this. Now, I need help to make sure users work on a workbook one row at a time. I only want the row in use (active row) to be unlocked. The rows below the active row need to be locked, and the finished rows locked. The workbook already has allot of code already done. I may be long winded, but I will try to be thorough.

There is a module (Module 1) that on start-up extracts data from a closed workbook. Each worksheet also has an update button (active-x) linked to this module.

In the "This workbook" section the code protects the workbook and enables Module 1 to extract data from an external workbook on open.

The sheets have code to protect individual cells, automatically add dates, and lock the active row when the required data is entered. There is also code for an active-x button that can manually update the sheet with the code used in Module 1.

The plan is to lock everything below the active row. Once the cell that now locks the active row is enabled, it not only locks the active row, it unlocks the required cells in the next row. It must only unlock columns B,C,D,F,G,I,J,K, L,M,N and O.

Columns B,C,D,F,I,J,L,M, and O are manual entries. Columns G,K and N have pull-downs. Columns E,H, and P are auto filled and always locked.

Here is all the code in the project. I don't know if you need it but here it is anyway.

This is the code in the "Thisworkbook" section
VBA Code:
Private Sub Workbook_Open()
  Dim ws As Worksheet
  For Each ws In Worksheets
    ' UserInterfaceOnly:=True allows code to change data.
    ws.Protect "password", UserInterfaceOnly:=True, DrawingObjects:=True, _
      Contents:=True, Scenarios:=True, AllowFiltering:=True
  Next ws
UpdateDataFromMasterFile
End Sub

This is in Module 1
VBA Code:
Sub UpdateDataFromMasterFile()
    Dim wbMaster As Workbook
    Dim wbMinion As Workbook
    Dim wsMaster As Worksheet
    Dim wsMinion As Worksheet
    Dim noRows&
    Dim i&
    Dim arrMaster()
    Dim arrMinion()
    
    On Error GoTo ErrorHandler
    
    Const wbMasterFileDir$ = "S:\Radiology\FLUORO LOG BOOKS\Approved Fluoroscopy List.xlsm"
    
    If Not (Len(Dir(wbMasterFileDir)) > 0) Then
        MsgBox "Provided master file directory does not exist!" & vbNewLine & _
                "Path: " & wbMasterFileDir, vbCritical, "InfoLog"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set wbMinion = ThisWorkbook
    Set wsMinion = wbMinion.Sheets(1)
    
    Set wbMaster = Workbooks.Open(wbMasterFileDir) 'GetObject(wbMasterFileDir)
    Set wsMaster = wbMaster.Sheets(1)
    
    With wsMaster
        noRows = .Range("A" & Cells.Rows.Count).End(xlUp).Row
        
        If noRows = 1 Then
            Application.ScreenUpdating = True
            MsgBox "There's no data to pull from Master File!", vbExclamation, "InfoLog"
            Exit Sub
        End If
        
        arrMaster = .Range("A2:A" & noRows)
        
        WbMasterClose wb:=wbMaster
        
        arrMinion = wsMinion.Range("A2:A" & noRows)
    End With
    
    For i = 1 To UBound(arrMaster, 1)
        arrMinion(i, 1) = arrMaster(i, 1)
    Next i
        
    wsMinion.Range("A2:A" & noRows) = arrMinion
            
    MsgBox "Update completed.", vbInformation, "InfoLog"
    
DataClearance:
    Application.ScreenUpdating = True
    Set wbMinion = Nothing
    Set wsMinion = Nothing
    Set wbMaster = Nothing
    Set wbMinion = Nothing
    
    Exit Sub

ErrorHandler:
    MsgBox "Unexpected error occured!", vbCritical, "InfoLog"
    Resume DataClearance
    
End Sub
Private Sub WbMasterClose(wb As Workbook)
    On Error Resume Next
    Application.DisplayAlerts = False
    wb.Saved = False
    wb.Close
    Application.DisplayAlerts = True
End Sub

Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub
This code is in all the sheets in the workbook. All the sheets are the same except sheet 1. Sheets 2 and on are what I need to fix.
VBA Code:
Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Union(Range("K6:K5000"), Range("N6:N5000"))
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
   Application.EnableEvents = False
    For Each c In r
    Select Case True
      Case 11 = c.Column 'K
        If c.Value = "" Then
          Cells(c.Row, "L").Value = ""
          Cells(c.Row, "L").Locked = True
          Else
          Cells(c.Row, "L").Locked = False
        End If
      Case 14 = c.Column 'N
        If c.Value = "" Then
          Cells(c.Row, "O").Value = ""
          Cells(c.Row, "O").Locked = True
          Else
          Cells(c.Row, "O").Locked = False
        End If
      Case Else
    End Select
  Next c
  End If
   If Target.Cells.Count > 4 Then Exit Sub
  If Not Intersect(Target, Range("B6:B5000")) Is Nothing Then
    With Target(1, 4)
     .Value = Date
     .EntireColumn.AutoFit
    End With
    End If
     Dim p As Range
     Set p = Range("L6:L5000")
     Set p = Intersect(Target, p)
     For Each p In Target
     Select Case True
     Case 12 = p.Column 'L
     If p.Value <> "" Then
        Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
            If Check = vbYes Then
            Target.Rows.EntireRow.Locked = True
            Else
            Cells(p.Row, "L").Value = ""
            End If
          End If
      Case Else
    End Select
   Next p
  Application.EnableEvents = True
End Sub

I hope this is not a monumental task, and someone is up to the challenge.

Thank you so much in advance,
Jim
 

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

XrayLemi

Board Regular
Joined
Aug 1, 2018
Messages
87
Office Version
  1. 365
Platform
  1. Windows
Okay, I got this to work. It works better than I thought it would even if it is not very polished. I know there must be an easier way, but for now I'll take it!
Here is the code I used.
VBA Code:
Dim p As Range
     Dim unlk As Range
     Set unlk = Union(Range("B6:D5000"), Range("F6:G5000"), Range("I6:K5000"), Range("M6:N5000"))
     Set p = Range("P6:P5000")
     Set p = Intersect(Target, p)
     For Each p In Target
     Select Case True
     Case 16 = p.Column 'P
     If p.Value <> "" Then
        Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
            If Check = vbYes Then
            Target.Rows.EntireRow.Locked = True
            Cells(p.Row + 1, "B").Locked = False
            Cells(p.Row + 1, "C").Locked = False
            Cells(p.Row + 1, "D").Locked = False
            Cells(p.Row + 1, "F").Locked = False
            Cells(p.Row + 1, "G").Locked = False
            Cells(p.Row + 1, "I").Locked = False
            Cells(p.Row + 1, "J").Locked = False
            Cells(p.Row + 1, "K").Locked = False
            Cells(p.Row + 1, "M").Locked = False
            Cells(p.Row + 1, "N").Locked = False
            Cells(p.Row + 1, "P").Locked = False
          Else
            Cells(p.Row, "L").Value = ""
           End If
          End If
      Case Else
    End Select
   Next p
  Application.EnableEvents = True
End Sub
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,127,098
Messages
5,622,674
Members
415,920
Latest member
ExcelNoob28

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
Top