I have an excel sheet where if a value is entered into a cell in column A, then the cell next to it in column B automatically generates the date and time. The problem I'm having is I want a check where if the value in column A is blank i.e. "" then the date and time is cleared too. I have figured out how to add the date and time just not how to add a check on the value of cell to see if it is blank.
The code is below along with an example;
Example;
A4 a change is made, the current date and time is entered into B4
A8 a change is made, the current date and time is entered into B8
A4 the user clears the cell (presses delete on their keyboard), B4 is cleared too.
A4 the user enters "hello world", the current date and time is entered again
Code;
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
xCellColumn = 2
xTimeColumn = 5
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
End If
End If
End Sub
Thanks
This works only for column A and column B:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target = vbNullString Then
Target.Offset(0, 1) = vbNullString
Else
Target.Offset(0, 1) = Now
End If
Application.EnableEvents = True
End Sub
If you want to make it work for any 2 columns, then remove this line:
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
The command Application.EnableEvents = True is used to make sure that the _Change event is not called once the Sub changes a cell.
Related
I need to copy the contents of a cell in a particular column to another corresponding column on change so the old value is moved. Only wants to work for a particular column.
Private sub Worksheet_Change(ByVal Target As Range)
if Target.Range("L:L") then
'set I cell value = to original L cell value
ActiveCell.Offset(0,-3).Value = ActiveCell.Value
End If
End Sub
This code should do what you want. Please take note of the comments which explain some limitations I have imposed on the action of this procedure. The rule to follow is to not give it more power than it needs to do the job you want it to do.
Private Sub Worksheet_Change(ByVal Target As Range)
' 027
Dim Rng As Range
' don't react if the changed cell is in row 1 or
' if it is more than 1 row below the end of column L
Set Rng = Range(Cells(2, "L"), Cells(Rows.Count, "L").End(xlUp).Offset(1))
If Not Application.Intersect(Target, Rng) Is Nothing Then
With Target
' skip if more than 1 cell was changed
' meaning, exclude paste actions
If .Cells.CountLarge = 1 Then
.Offset(0, -3).Value = .Value
End If
End With
End If
End Sub
This will save the previous value in column I:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v As Variant
If Target.Count > 1 Then Exit Sub
If Intersect(Range("L:L"), Target) Is Nothing Then Exit Sub
With Application
v = Target.Value
.EnableEvents = False
.Undo
Target.Offset(0, -3).Value = Target.Value
Target.Value = v
.EnableEvents = True
End With
End Sub
EDIT#1:
To update L without triggering the event, use something like:
Sub ScriptThatUpdatesColumn_L()
Application.EnableEvents = False
Range("L5").Value = "just me"
Application.EnableEvents = True
End Sub
I am using a simple code to enter date and time automatically in 2 separate cells in the excel sheet, however, they change automatically if I enter a new value in the cell or just press "Delete" Key. Below is the code I am using:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
Target.Offset(0, -2).Value = Date
Application.EnableEvents = True
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
Target.Offset(0, -1).Value = Time
Application.EnableEvents = True
End Sub
I need the date and time to remain static until I delete them from their respective cells. How can I achieve this?
This will preserve the date/time once they have been entered:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
Application.EnableEvents = False
If Target.Offset(0, -2).Value = "" And Target.Offset(0, -2).Value = "" Then
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
End If
Application.EnableEvents = True
End Sub
EDIT#1:
This version will allow you to both set and clear multiple cells in column E:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, i1 As Long, i2 As Long
If Target.Column <> 5 Then Exit Sub
With ActiveSheet.UsedRange
i2 = .Rows.Count + .Row - 1
i1 = .Row
End With
Application.EnableEvents = False
For Each r In Intersect(Target, Range("E" & i1 & ":E" & i2))
If r.Offset(0, -2).Value = "" And r.Offset(0, -1).Value = "" And r.Value <> "" Then
r.Offset(0, -2).Value = Date
r.Offset(0, -1).Value = Time
End If
Next r
Application.EnableEvents = True
End Sub
Clearing a cell that is already empty will not cause a time/date recording.
Stepping through your code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 5 Then Exit Sub
"If the target's column is not 5 then exit the subroutine" This is cool.
Application.EnableEvents = False
Flipping this to false insures that this code won't run again until this value is set to true. Worksheet_Change needs enableevents to be on. So now if the cell that changed was in Column E then Worksheet_Change will be kept from executing again. This makes sense to keep infinite loops from happening as cells are changed via this code.
Target.Offset(0, -2).Value = Date
Set the cell that is two columns back from the target cell to the current date.
Application.EnableEvents = True
Set enableEvents back on. This is good since you probably don't want to leave this off.
If Target.Column <> 5 Then Exit Sub
Why are we checking this again? Target.Column hasn't changed since last time, and if it was already <>5 then we wouldn't be here to test it. This line is superfluous.
Application.EnableEvents = False
OK.. Well we just turned this on, but now we are turning this off again. Just leave it off.
Target.Offset(0, -1).Value = Time
Set the value 1 column to the left of the target cell to the current time. Coolios.
Application.EnableEvents = True
Turn enableEvents back on. This makes sense here.
End Sub
Rewriting this to remove the redundant toggles and superflous target.Column check:
Private Sub Worksheet_Change(ByVal Target As Range)
'make sure this is column 5 that was changed. Like if anything changed in
' column 5, then run the rest of this.
If Target.Column <> 5 Then Exit Sub
'Make sure we don't infinite loop if we accidently trigger a change to
' column 5 in this code.
Application.EnableEvents = False
' Set two cells to the left to the current date
' and one cell to the left to the current time
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
'turn events back on.
Application.EnableEvents = True
End Sub
So.. Everytime you make a change in Column 5, the date and time change. IF you want it so that it only changes a row's date and time once. Then check to see if date and time are already set for the row:
Private Sub Worksheet_Change(ByVal Target As Range)
'make sure this is column 5 that was changed. Like if anything changed in
' column 5, then run the rest of this.
If Target.Column <> 5 Then Exit Sub
'Check to see if the date and time are already set for this row:
' If they are, then exit subroutine.
If target.offset(0,-2).value <> "" OR target.offset(0,-1).value <> "" Then Exit Sub
'Make sure we don't infinite loop if we accidently trigger a change to
' column 5 in this code.
Application.EnableEvents = False
' Set two cells to the left to the current date
' and one cell to the left to the current time
Target.Offset(0, -2).Value = Date
Target.Offset(0, -1).Value = Time
'turn events back on.
Application.EnableEvents = True
End Sub
In my sheet columns B:C allow dates. I'm trying to create a check to see whether a date entered in C is more recent than B, if so fine, else alert the user and clear contents.
My code returns a run-time error 91 in the application.intersect line:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)).Value > ActiveCell.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
I changed your method, but this seems to be working.
I also noticed that you were writing A2 to ActiveCell instead of Target. Did you want the cell in column C to update if invalid data is entered or did you intend for it to be whichever cell you move to that gets changed?
At any rate, here's a way I came up with it
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Target.Column = 3 Then 'Check to see if column C was modified
If Target.Value < Target.Offset(0, -1).Value Then
Target.ClearContents
Target.Value = "A2"
MsgBox "Please re-check dates"
End If
End If
End Sub
If you want to stick with the way you are currently doing it, then I think you need to check that the Intersection is not empty as another answer concludes.
I believe you just have to check the intersect than do the compare.
Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)) Is Nothing Then
If Target.Value < Target.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
You can just loop the rows and compare the dates.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Dim lRow As Long
lRow = 4
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("C" & lRow).Value > ws.Range("B" & lRow).Value then
GoTo DatesMissMatch
End if
lRow = lRow + 1
Loop
I am trying to take the value inside cell I-8 Multiplied by the value inside H-8 and have this new value X, replace the contents of cell I-8.
I am trying to do this with every row starting with 8. (I-9 * H-9 etc)
I am already removing cell's will qty 0 inside column I with the following:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim c As Range
Dim SrchRng
Set SrchRng = Intersect(ActiveSheet.UsedRange, Range("I:I"))
Do
Set c = SrchRng.Find(0, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
You actually need a different event for this to work:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 9 And Target.Cells.Count = 1 And Target.Row > 7 Then
Application.EnableEvents = False
If IsNumeric(Target.Value) Then Cells(Target.Row, 2).Value = Target.Value * Target.Offset(0, -1).Value
Application.EnableEvents = True
End If
End Sub
I feel it needs to pointed out however, that simply entering =H8*I8 into B8 will do the same thing.
I would like my Excel spreadsheet Column B to be stamped with a date time only when Column A first changes. I have seen a lot of VBA code but it captures the last change, not the first change.
I tried to use this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Offset(0, 1).Value = "" Then
Target.Offset(0, 1) = Format(Now(), "HH:MM:SS")
End If
End Sub
It worked except when I copy and paste into say 3 rows, the date time stamp only shows up for the first of 3 records.
Below code works for me
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Target.Column = 1 And Target.Offset(0, 1).Value = "" Then
Target.Offset(0, 1) = Format(Now(), "HH:MM:SS")
End If
Application.EnableEvents = True
End Sub
I receive an error message when attempting to paste into several cells of column A, from this line:
Target.Offset(0, 1).Value = ""
This is because the Offset is a Range of more than one cell, and we can't compare the Value of this Range to an individual value.
You can check Target.Rows.Count. If this is greater than 1 then you can loop through the Target Range, each time checking if the adjacent cell is empty before entering a value into Offset(0, 1).
The following loops through the Target cells, and works even if the Target is a single cell:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Column = 1 Then
Application.EnableEvents = False
For Each rng In Target
If rng.Offset(0, 1).Value = "" Then
rng.Offset(0, 1) = Format(Now(), "HH:MM:SS")
End If
Next rng
Application.EnableEvents = True
End If
End Sub
You should also check if Target extends beyond a single column. If it does, then presumably you only want to enter the stamp into column B (for a change in column A).