Locking a row of cells after the last entry in a row

[XrayLemi]

Hello everyone,
I had posted this before but my workbook has changed significantly since posting originally. I have been told re-post it. Because of security, I cannot use XL2BB so I will have to use images as well as the code I paste. I will try to be as thorough as I can because (I think at least) there is a lot going on already.

I have a workbook where I need to be able to lock a row of cells once the last entry in that row is made. The data entry order can vary (column J might be the last entry one time, column C might be the last next time. etc..) There are also two columns that may or may not have values entered. Those columns are I and K. Column K is only filled automatically if a certain value is entered in column J otherwise it is blank and locked. Column I may or may not have any entry. All the rest of the columns B-L will have an entry. Columns G and J have pull down menus. The date in column E is an automatic entry using VBA and is locked (code at the end of the post). Column H is locked (VBA) until the value in column G is entered. If the user removes the value in G the value in H is removed and the cell re-locked.
The rest of the VBA on the sheet is to pull data from a separate master file and insert / update the data list on sheet 1 for the drop down list in the cells in column J. There is also a button command to update the list

Here is the code I have so far.

This code is on or will be on every sheet except sheet 1

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
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Range("G6:G5000")
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
  Application.EnableEvents = False
  For Each c In r
    Select Case True
      Case 7 = c.Column 'G
        If c.Value = "" Then
          Cells(c.Row, "H").Value = ""
          Cells(c.Row, "H").Locked = True
          Else
          Cells(c.Row, "H").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
  Application.EnableEvents = True
End Sub

This code is in the This Workbook section for protection.

Private Sub Workbook_Open()
  Dim ws As Worksheet
  For Each ws In Worksheets
    ' UserInterfaceOnly:=True allows code to change data.
    ws.Protect "exceler8", UserInterfaceOnly:=True, DrawingObjects:=True, _
      Contents:=True, Scenarios:=True, AllowFiltering:=True
  Next ws
End Sub

I posted all the code in the workbook just in case some of the new code will affect the old code. I know how much work this is and how hard it is. This is why i'm here. I had allot of help with this. Because I only know enough to do very minor things if I have something to copy and manipulate from.
Thank you so much in advance,
Jim Lemieux

 

[XrayLemi]

I forgot to mention, I also need a warning box to appear when the last entry is made. It will remind the user to check their entries before the row is locked. Then it will lock the row. I'm sorry I know that is a major oops.
But thanks again.
Jim

 

[XrayLemi]

OK, I did some digging, I actually got this to work for a single cell (column "H"). The warning box works as well. I just can't seem to make it work for multiple columns (B,C,D,F,G,H,J,L) in that same row. The code I used is at the bottom.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Range("G6:G5000")
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
  Application.EnableEvents = False
  For Each c In r
    Select Case True
      Case 7 = c.Column 'G
        If c.Value = "" Then
          Cells(c.Row, "H").Value = ""
          Cells(c.Row, "H").Locked = True
          Else
          Cells(c.Row, "H").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 cl As Range
     Set cl = Range("H6:H5000")
     Set cl = Intersect(Target, cl)
     For Each cl In Target
     Select Case True
     Case 8 = cl.Column 'H
     If cl.Value <> "" Then
        Check = MsgBox("Is this entry correct?" & vbCrLf & "This cell cannot be edited after entering a value.", vbYesNo + vbQuestion, "Cell Lock Notification")
            If Check = vbYes Then
            Cells(cl.Row, "H").Locked = True
            Else
            Cells(cl.Row, "H").Value = ""
            End If
          End If
      Case Else
    End Select
   Next cl
  Application.EnableEvents = True
End Sub

I just can't seem to get over this hump.
Thanks,
Jim

 

[XrayLemi]

I have tried repeatedly to get something to work. Any code I have found to lock the remainder of the cells in the row I need locked, ends up locking the whole sheet. It usually locks the sheet after the first entry. Then I cannot enter any additional values in that row or the entire sheet. The closest thing I have found that even comes close to working, is this.

Private Sub Worksheet_Change(ByVal Target As Range)
    Const PASSWORD = "PASSWORD"
    Dim Row As Long
    If Target.Column = 12 Then
        Target.Parent.Unprotect PASSWORD
        Row = Target.Row
        Target.Parent.Range("A" & Row & ":" & "L" & Row).Locked = True
        Target.Parent.Protect PASSWORD
    End If
End Sub

This will allow me to enter all the cell values in the row up to the target cell. However it then locks the entire sheet after the target cell value is entered. not just the row I need locked.

I'm really stuck hope someone can help.
Thank you in advance,
Jim