Excel locking cells with a date and time not working - excel

Question

I want to have a sheet were after I enter a truck number it automatically places the date and time in a following cell, that works no problem, but when I try to place a protection on the cells after data has been enter so it cannot be modify it gives me errors, what am I doing wrong?
I have selected the complete sheet and unlock the cells, then I have wrote this code on the visual basic for excel
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect Password:="YourPassword"
Target.Locked = True
ActiveSheet.Protect Password:="YourPassword"
Dim x As Integer
Dim y As Integer
For x = 2 To 1000
For y = 2 To 1000
If Cells(x, 3).Value <> "" And Cells(x, 5).Value = "" Then
Cells(x, 5).Value = Date & " " & Time
Cells(x, 5).NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
End If
Next
Range("B:B").EntireColumn.AutoFit
If Cells(y, 6).Value <> "" And Cells(y, 7).Value = "" Then
Cells(y, 7).Value = Date & " " & Time
Cells(y, 7).NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
End If
Next
Range("B:B").EntireColumn.AutoFit
End Sub
[ ]2]2
this is the code and error
after I apply the code for the protection the time and date doesnt stamp anymore

Answer 1

Worksheet Change: Monitoring 2 Non-Adjacent Columns
Adjust the values in the constants section, especially the password ('pw').
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
ScanTrucks Target
End Sub
Private Sub ScanTrucks(ByVal Target As Range)
On Error GoTo ClearError
' Scan In
Const siCol As String = "C"
Const diCol As String = "E"
' Scan Out
Const soCol As String = "F"
Const doCol As String = "G"
' Both
Const fRow As Long = 2
Const afCol As String = "B"
Const pw As String = "123"
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim scrg As Range
Dim srg As Range
Dim sCell As Range
Dim drg As Range
Dim dCell As Range
' Scan In
Set scrg = ws.Columns(siCol)
With scrg
Set srg = Intersect(Target, _
.Resize(.Rows.Count - fRow + 1).Offset(fRow - 1))
End With
If Not srg Is Nothing Then
For Each sCell In srg.Cells
If Len(CStr(sCell.Value)) > 0 Then
Set dCell = sCell.EntireRow.Columns(diCol)
If Len(CStr(dCell.Value)) = 0 Then
Set drg = RefCombinedRange(drg, dCell)
End If
End If
Next sCell
End If
' Scan Out
Set srg = Nothing
With scrg.EntireRow.Columns(soCol)
Set srg = Intersect(Target, _
.Resize(.Rows.Count - fRow + 1).Offset(fRow - 1))
End With
If Not srg Is Nothing Then
For Each sCell In srg.Cells
If Len(CStr(sCell.Value)) > 0 Then
Set dCell = sCell.EntireRow.Columns(doCol)
If Len(CStr(dCell.Value)) = 0 Then
Set drg = RefCombinedRange(drg, dCell)
End If
End If
Next sCell
End If
If drg Is Nothing Then Exit Sub
' Unprotect, format, write and protect.
ws.Unprotect Password:=pw
Application.EnableEvents = False
ws.Columns(afCol).AutoFit
With drg
.NumberFormat = "m/d/yyyy h:mm:ss AM/PM"
.Value = Now
.Locked = True
End With
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
If Not ws.ProtectionMode Then ws.Protect Password:=pw
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "':" & Err.Description
Resume SafeExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function