Modify existing VBA code to stop cells unlocking when a value has been entered.

[danbates]

Hi,

Please can someone help me?

The following code is for a sheet I have that we do daily safety checks on.

This code only allows the operator to enter their safety checks for their shift on that particular day/night.

After the operator has entered all the checks and saved the file, if you click on one of the checks again the code is unlocking the cell(s). You can't save the file again but you can change the data and it will lock the cells once that particular shift has passed.

So what I would like is the code to check if the cell is empty or not before unlocking the cell.

I hope this kind of makes sense and any help would be much appreciated.

Kind Regards

Dan

Here is the code:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    Dim sCurrentMonth As String
    Dim dCurrentTime As Double
    Dim iCurrentDate As Integer
    Dim rng As Range
    Dim rTbl As Range
    Dim rTbl2 As Range
    Dim rTbl3 As Range
    Dim rFound As Range
    Dim bComplete As Boolean


    'exit if more than one cell is selected
    If Target.CountLarge > 1 Then Exit Sub


    'reset form closed flag
    bClosedUserForm1 = False


    'get current month and set its shift row
    sCurrentMonth = Format(Date, "mmmm")
    'get current home row
    Set rFound = Cells.Find(What:=sCurrentMonth, LookIn:=xlFormulas, Lookat:=xlPart)
    If Not rFound Is Nothing Then
        nCurrentShiftRow = rFound.Row + iRowsBelowMonth
    Else
        MsgBox "Current month not found."
        Exit Sub
    End If


    'get current system time
    dCurrentTime = TimeValue(Now)


    'get current day number
    iCurrentDate = Day(Date)


    'get current day column - because the date columns are merged it returns the first column of the merge
    Set rTbl = Range("D4:BM4")
    Set rFound = rTbl.Find(What:=iCurrentDate, LookIn:=xlFormulas, Lookat:=xlWhole)
    If Not rFound Is Nothing Then
        'get shift "D" = 06:00 to 18:00 or "N" = 18:00 to 06:00
        If Not dCurrentTime > 0.75 And Not dCurrentTime < 0.25 Then
            nTargetColumn = rFound.Column
        Else
            If dCurrentTime <= 0.25 Then
                nTargetColumn = rFound.Column - 1 'must be midnight to 06:00 on previous date "N"
            ElseIf dCurrentTime > 0.75 Then
                nTargetColumn = rFound.Column + 1 'must be 18:00 to midnight on current date "N"
            End If
        End If
    Else
        MsgBox "Current date not found."
        Exit Sub
    End If


    'ensure only current date column and rows 5 to 19 can be processed
    If Target.Column = nTargetColumn Then
        If Not Target.Row > nCurrentShiftRow + iNumOfCheckRows + 1 And Not Target.Row < nCurrentShiftRow + 1 Then


            Application.EnableEvents = False


            'unprotect sheet to clear cell colours caused by previous missing entry
            UnprotectTheActiveSheet
            Set rTbl2 = Range(Cells(nCurrentShiftRow, nTargetColumn), Cells(nCurrentShiftRow + iNumOfCheckRows, nTargetColumn))
            rTbl2.Interior.Color = xlNone
            'ensure any remaining colours are cleared if shift changes
            Set rTbl3 = Range(Cells(nCurrentShiftRow, nTargetColumn - 1), Cells(nCurrentShiftRow + iNumOfCheckRows, nTargetColumn - 1))
            rTbl3.Interior.Color = xlNone


            'check 'Initials' row has been selected
            If Target.Row = nCurrentShiftRow + iNumOfCheckRows + 1 Then


                'initialise flag
                bComplete = True


                'check all required current shift cells have been completed
                'if incomplete, identify cell, send user message and exit safely
                For Each rng In rTbl2
                    If rng = "" Then
                        Cells(nCurrentShiftRow, nTargetColumn).Select
                        Cells(nCurrentShiftRow, nTargetColumn).Interior.Color = RGB(155, 194, 230)
                        rng.Interior.Color = RGB(255, 0, 0)
                        ProtectTheActiveSheet
                        Application.EnableEvents = True
                        MsgBox "Please complete where highlighted."
                        bComplete = False
                        Exit Sub
                    End If
                Next rng


                'call initials form if all required entries are complete
                If bComplete Then Call DisplayUserForm1ForSheetsThatNeedInitialsFromUserForm(Target)


                'reprotect wsheet
                ProtectTheActiveSheet
            End If


            Application.EnableEvents = True
        End If
    Else
        'if user selects a non current date when initials form is not loaded
        If Not bClosedUserForm1 Then
            ActiveWindow.ScrollRow = nCurrentShiftRow - 2
            Cells(nCurrentShiftRow, nTargetColumn).Select
            UnprotectTheActiveSheet
            Cells(nCurrentShiftRow, nTargetColumn).Interior.Color = RGB(155, 194, 230)
            ProtectTheActiveSheet
            MsgBox "Please select the current date and shift column indicated."
        End If
    End If


End Sub