remove date if

[Trevor3007]

hello & good evening,

I use the following code:-

Private Sub Worksheet_Change(ByVal Target As Range)


ActiveSheet.Unprotect


Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim r As Long
Dim c As Long

Set rng = Intersect(Target, Range("E2:G200"))

' Exit sub if no cells updated in range
If rng Is Nothing Then Exit Sub

Application.EnableEvents = False

' Loop through updated cells in range
For Each cell In rng
' Get row and column number of updated cell
r = Target.Row
c = Target.Column
' Count how many cells have "Y" in current row
Set rng2 = Range("E" & r & ":G" & r)
If Application.WorksheetFunction.CountIf(rng2, "Y") > 1 Then
' Clear entry
cell.ClearContents
' Return message
MsgBox "You can put one Y in cell range E-G " & cell.Address(0, 0), vbOKOnly, "ERROR!"
Else
' See which column was updated and make appropriate adjustments
If LCase(cell) = "y" Then
Select Case c
' What to do if column E updated to "y"
Case 5
'enter any desired code here
' What to do if column F updated to "y"
Case 6
'enter any desired code here
' What to do if column G updated to "y"
Case 7
With Cells(r, "B")
.NumberFormat = "dd/mm/yyyy"
.Value = Date
End With
End Select
End If
End If
Next cell

Application.EnableEvents = True

ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True


End Sub

This works but the issue I have is that when I remove the 'Y' from cell G2.. the date remains in cell B2.

Can some kind and more knowledgeable person solve this for me please?

Many thanks in advance & I thank you for your time & assistance to day

 

[Rick Rothstein]

hello & good evening,

I use the following code:-

[table="width: 500"]
[tr]
	[td]Private Sub Worksheet_Change(ByVal Target As Range)
    
    
    ActiveSheet.Unprotect
   
  
    Dim rng As Range
    Dim rng2 As Range
    Dim cell As Range
    Dim r As Long
    Dim c As Long
  
    Set rng = Intersect(Target, Range("E2:G200"))
    
'   Exit sub if no cells updated in range
    If rng Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
'   Loop through updated cells in range
    For Each cell In rng
'       Get row and column number of updated cell
        r = Target.Row
        c = Target.Column
'       Count how many cells have "Y" in current row
        Set rng2 = Range("E" & r & ":G" & r)
        If Application.WorksheetFunction.CountIf(rng2, "Y") > 1 Then
'           Clear entry
            cell.ClearContents
'           Return message
            MsgBox "You can put one Y in cell range E-G  " & cell.Address(0, 0), vbOKOnly, "ERROR!"
        Else[B][COLOR="#FF0000"]If Application.WorksheetFunction.CountIf(rng2, "Y") = 1 Then[/COLOR][/B]
'           See which column was updated and make appropriate adjustments
            If LCase(cell) = "y" Then
                Select Case c
'                   What to do if column E updated to "y"
                    Case 5
                        'enter any desired code here
'                   What to do if column F updated to "y"
                    Case 6
                        'enter any desired code here
'                   What to do if column G updated to "y"
                    Case 7
                        With Cells(r, "B")
                            .NumberFormat = "dd/mm/yyyy"
                            .Value = Date
                        End With
                End Select
            End If
[B]        [B][COLOR="#FF0000"]Else
            Cells(r, "B").Value = ""[/COLOR][/B]
[/B]        End If
    Next cell
    
    Application.EnableEvents = True
    
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True


End Sub[/td]
[/tr]
[/table]

This works but the issue I have is that when I remove the 'Y' from cell G2.. the date remains in cell B2.

(Untested) Do the additions that I show in red above make the code work the way you want?

 

[Trevor3007]

Do the additions that I show in red above make the code work the way you want?

thank you ...thats solved my issue perfectly.


Have a great wekend.

KR
Trevor3007