CODEWITHSUNDEEP
excelvbacell
timetravelprimer
timetravelprimer

Reputation: 111

Don't allow empty cell with Intersect method

I use data validation where user can select only two values in a list.

I'm also using Intersect method to add timestamp in the next cell when the change in a cell occurs.

The user, however, can still delete a value and leave the cell blank, and this is something I need to prevent.

Is it possible to implement this in the code below?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Pass As String
Pass = "somepassword"

ActiveSheet.Unprotect Password:=Pass

 If Not Intersect(Target, Me.ListObjects("Table1").ListColumns(6).DataBodyRange) Is Nothing Then

   On Error GoTo ErrHandler

   ActiveSheet.Unprotect Password:=Pass
   Target.Offset(0, 1).Value = Format(Now, "dd.mm.yyyy hh:mm")
   ActiveSheet.Protect Password:=Pass, DrawingObjects:=True, Contents:=True, 
   Scenarios:=True, AllowFiltering:=True


End If

ErrHandler:
Exit Sub

End Sub

Upvotes: 0

Views: 484

Answers (2)

Xabier
Xabier

Reputation: 7735

How about the following, it will check whether the target value is nothing and prompt a message, also you might have to review how you protect and unprotect the sheet, as I'm unsure how the user is entering data if it's protected.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Pass As String
Pass = "somepassword"

If Not Intersect(Target, Me.ListObjects("Table1").ListColumns(6).DataBodyRange) Is Nothing Then
 ActiveSheet.Unprotect Password:=Pass
    On Error GoTo ErrHandler
    For Each acell In Target.Cells
        With acell
            If acell.Column = Me.ListObjects("Table1").ListColumns(6).Range.Column Then acell.Offset(0, 1).Value = Format(Now, "dd.mm.yyyy hh:mm")
        End With
    Next

    Set foundblank = Me.ListObjects("Table1").ListColumns(6).DataBodyRange.Find(What:="", LookIn:=xlValues, LookAt:=xlWhole)
    If Not foundblank Is Nothing Then
        MsgBox "Blank cell found", vbInformation, "Blank Found!"
        ActiveSheet.Protect Password:=Pass, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        Exit Sub
    End If
    ActiveSheet.Protect Password:=Pass, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End If

ErrHandler:
Exit Sub
End Sub

Upvotes: 0

Edimar Alves da Silva
Edimar Alves da Silva

Reputation: 84

try this code:

Option Explicit

Dim OldTargetAddress As String
Dim OldTargetValue As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = OldTargetAddress And Target.Value = Empty Then
    Application.EnableEvents = False
    Target.Value = OldTargetValue
    Application.EnableEvents = True
    Exit Sub
End If


Dim Pass As String
Pass = "somepassword"

ActiveSheet.Unprotect Password:=Pass

 If Not Intersect(Target, Me.ListObjects("Table1").ListColumns(6).DataBodyRange) Is Nothing Then

   On Error GoTo ErrHandler

   ActiveSheet.Unprotect Password:=Pass
   Target.Offset(0, 1).Value = Format(Now, "dd.mm.yyyy hh:mm")
   ActiveSheet.Protect Password:=Pass, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True


End If

ErrHandler:
Exit Sub

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    OldTargetAddress = Target.Address
    OldTargetValue = Target.Value
End Sub

Upvotes: 1

Related Questions