rbobcat1
New Member
- Joined
- Dec 19, 2011
- Messages
- 19
- Office Version
- 365
- Platform
- Windows
I came across the below VBA and need some help to modify it.
First it auto fills the date and time in I1 whenever you selected from a drop down in H1.
I have also added another to it that adds date and time to cell J1 whenever you choose "Closed" in cell E1.
This all works great for what I want with one exception, if H1 or E1 change by accident it updates the date and time in cells I1 and J1.
This is not what i want.
is there anyway to also force it to make the Date and Time in cells I1 and J1 permanent?
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rCell As Range
Dim rChange As Range
Dim rChanges As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("H5:H1048576"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, 1)
.Value = Now
End With
Else
rCell.Offset(0, 1).Clear
End If
Next
End If
On Error GoTo ErrHandler
Set rChanges = Intersect(Target, Range("E5:E1048576"))
If Not rChanges Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChanges
If rCell = "Closed" Then
With rCell.Offset(0, 5)
.Value = Now
End With
Else
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Set rChanges = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
First it auto fills the date and time in I1 whenever you selected from a drop down in H1.
I have also added another to it that adds date and time to cell J1 whenever you choose "Closed" in cell E1.
This all works great for what I want with one exception, if H1 or E1 change by accident it updates the date and time in cells I1 and J1.
This is not what i want.
is there anyway to also force it to make the Date and Time in cells I1 and J1 permanent?
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim rCell As Range
Dim rChange As Range
Dim rChanges As Range
On Error GoTo ErrHandler
Set rChange = Intersect(Target, Range("H5:H1048576"))
If Not rChange Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChange
If rCell > "" Then
With rCell.Offset(0, 1)
.Value = Now
End With
Else
rCell.Offset(0, 1).Clear
End If
Next
End If
On Error GoTo ErrHandler
Set rChanges = Intersect(Target, Range("E5:E1048576"))
If Not rChanges Is Nothing Then
Application.EnableEvents = False
For Each rCell In rChanges
If rCell = "Closed" Then
With rCell.Offset(0, 5)
.Value = Now
End With
Else
End If
Next
End If
ExitHandler:
Set rCell = Nothing
Set rChange = Nothing
Set rChanges = Nothing
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub