I am trying to build a log book where:
Once the operator enters information that cell should lock.
A date and time for the entry should auto populate.
I have tried several codes I found on bulletin boards, but nothing works.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Application.EnableEvents = False
If Target.Column = 2 Or Target.Column = 3 Then
For i = 2 To 1000
If Cells(i, "B").Value <> " " And Cells(i, "B").Value = " " Then
Cells(i, "A").Value = Date & " " & Time
Cells(i, "A").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next
End If
Range("F:F").EntireColumn.AutoFit
Application.EnableEvents = True
End Sub
In the same article you have a solution:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim bc As Range 'no sense in declaring something until we actually need it
For Each bc In Intersect(Target, Range("B:B")) 'deal with every cell that intersects. This is how to handle pastes into more than one cell
If Not IsEmpty(Cells(bc.Row, "B")) Then
Cells(bc.Row, "A").Value = Now 'Now is the equivalent of Date + Time
Cells(bc.Row, "A").NumberFormat = "m/d/yyyy h:mm AM/PM"
End If
Next bc
'Range("F:F").EntireColumn.AutoFit 'this slows things down. you may want to comment this out and just set an apprpriate column width that will handle everything
End If
SafeExit:
Application.EnableEvents = True
End Sub
I just addpat for your case on Range B:B.
Hope it helps
Related
So I have this case where a specific range in two separate columns are going to be filled out. In either case there should be a date stamped in column F and time stamp in column G. This version I have works to some extend however when you clear out any cell outside of one you get a type mismatch error
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Handler
If Not Intersect(Target, Range("D8:D31,D44:D67,D80:D103,D116:D139")) And Target.Value <> ""
Then
Application.EnableEvents = False
Target.Offset(0, 2) = Format(Now(), "mm-dd-yyyy")
Target.Offset(0, 3) = Format(Now(), "hh:mm:ss")
Application.EnableEvents = True
Handler:
End If
On Error GoTo Handler2
If Not Intersect(Target, Range("E8:E31,E44:E67,E80:E103,E116:E139")) And Target.Value <> ""
Then
Application.EnableEvents = False
Target.Offset(0, 1) = Format(Now(), "mm-dd-yyyy")
Target.Offset(0, 2) = Format(Now(), "hh:mm:ss")
Application.EnableEvents = True
Handler2:
End If
End Sub
I assuming this breaks the initial if not logic and that is why its erroring out in that manner.
You can simplify this a little by only intersecting on a single range, and also be able to handle multiple cells being updated:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
On Error GoTo haveError
Set rng = Application.Intersect(Target, _
Me.Range("D8:E31,D44:E67,D80:E103,D116:E139"))
If Not rng Is Nothing Then 'any cells of interest updated?
Application.EnableEvents = False
For Each c In rng.Cells 'loop over updated cells
If Len(c.Value) > 0 Then 'has value?
With c.EntireRow
.Columns("F").Value = Format(Now(), "mm-dd-yyyy")
.Columns("G").Value = Format(Now(), "hh:mm:ss")
End With
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
Advice would be gratefully appreciated. I am developing a spreadsheet using Excel 2016/Windows.
I have written 4 eventchange subroutines and all work well. The VBA Code for a worksheet checks for 4 events. Event 1, 2 and 3 enter today's date in a cell if data is entered in another cell (code not included below)
Code for EventChange works fine, but sometimes works when not expected to!
EventChange4 moves a value from one cell to another if another cell contains the text in Column J is "THIS Month – Payment Due" or "Issued But Not Paid. The second part of this eventchange4 moves a zero value to 2 cells if the data in column j contains text "not going ahead"
I am new to VBA. The problem is that eventchange4 runs for no apparent reason, e.g. copying a cell value in column H down to another cell in column h. How can I modify the code such that that eventchange4 only runs when the data in Column J Changes??? All advice gratefully accepted!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Call EventChange_1(Target)
Call EventChange_2(Target)
Call EventChange_3(Target)
Call EventChange_4(Target)
End Sub
Sub EventChange_1(ByVal Target As Range)
'Update on 11/11/2019 -If data changes in column L, insert
'today's date into column M
End Sub
Sub EventChange_2(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column P, insert today's date
'into next Column Q
End Sub
Sub EventChange_3(ByVal Target As Range)
'Update on 15/01/2020 -If data changes in column R, insert today's date
'into next Column S
End Sub
Sub EventChange_4(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
' this works !
If Target.Column = 10 And (Target.Value = "THIS Month – Payment Due" Or Target.Value = "Issued But Not Paid") Then
Range("K" & Target.Row).Value = Range("I" & Target.Row).Value
Range("I" & Target.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If Target.Column = 10 And (Target.Value = "Not Going Ahead") Then
Range("I" & Target.Row).Value = 0
Range("K" & Target.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Application.EnableEvents = True
End Sub
Ideally you should update your code so it can properly handle a Target range which is not just a single cell:
Sub EventChange_4(ByVal Target As Range)
Dim rng As Range, c As Range, v
'any part of Target in Column J?
Set rng = Application.Intersect(Target, Me.Columns(10))
If Not rng Is Nothing Then
'have some cells to process...
On Error GoTo haveError
Application.EnableEvents = False
'process each affected cell in Col J
For Each c In rng.Cells
v = c.Value
If v = "THIS Month – Payment Due" Or v = "Issued But Not Paid" Then
Range("K" & c.Row).Value = Range("I" & c.Row).Value
Range("I" & c.Row).Clear
MsgBox "Moved Commission Due to Month Paid"
End If
If v = "Not Going Ahead" Then
Range("I" & c.Row).Value = 0
Range("K" & c.Row).Value = 0
MsgBox "Moved ZERO to Initial Commisson and Month Paid"
End If
Next c
End If
haveError:
Application.EnableEvents = True
End Sub
NOTE: this is assumed to be in the relevant worksheet code module - otherwise you should qualify the Range() calls with a specific worksheet reference.
All your "change" handlers should follow a similar pattern.
Tim apologies. I am new to this and was anxious to get a solution. Thank you for your response. Advice Noted. T
When I attempt to insert or delete a row in the spreadsheet, the VBA code identifies a worksheet event and attempts to run the code. The spreadsheet crashes. I have attempted to add code that will prevent this by checking at the beginning of the module if a row has been inserted or deleted before the other worksheet change event if statements are checked
Thank you
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
Dim wsInc As Worksheet
Dim count As Integer
Dim lRow As Long
Dim ans As Variant
Dim tb As ListObject
On Error GoTo Whoa
Application.EnableEvents = False
Set tb = ActiveSheet.ListObjects(1)
MsgBox Target.Rows.count
If tb.Range.Cells.count > count Then
count = tb.Range.Cells.count
' GoTo Whoa
ElseIf tb.Range.Cells.count < count Then
count = tb.Range.Cells.count
' GoTo Whoa
'~~> Check if the change happened in Col A
ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End With
Next
'~~> Check if the change happened in Col L
ElseIf Not Intersect(Target, Columns(12)) Is Nothing Then
Set wsInc = Sheets("Income")
lRow = wsInc.Range("A" & wsInc.Rows.count).End(xlUp).Row + 1
For Each aCell In Target.Cells
With aCell
If Len(Trim(.Value)) = 0 Then
.Offset(, 1).ClearContents
Else
.Offset(, 1).NumberFormat = "dd/mm/yyyy"
.Offset(, 1).Value = Now
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'~~> Check of the value is Fees Received, Policy No. Issued
If .Value = "Fees Received" Or .Value = "Policy No. Issued" Then
ans = MsgBox("Do you want to copy this client to the Income Worksheet?", vbQuestion + vbYesNo)
If ans = False Then Exit For
wsInc.Range("A" & lRow).Value = Range("A" & aCell.Row).Value
End If
End If
End With
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
The code returns error messages implying some parts of code are missing yet they are there. E.g With without End With, and of course it's there.
These are two codes that i wrote separately with the aim of combining after making sure that they function well. But it turns out i need some help to get them together.
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False
Dim k As Integer
Dim j As Integer
If Target.Column = 4 Then
confirm = MsgBox("Do you wish to confirm entry of this data?" _
& vbCrLf & "You'll not be allowed to change it!", vbYesNo, "confirm Entry")
Select Case confirm
Case Is = vbYes
Dim Cell As Range
With ActiveSheet
.Unprotect Password:="10"
.Cells.Locked = False
For Each Cell In ActiveSheet.UsedRange
For j = 4 To 4
For k = 10 To 60
If Cells(k, j).Value <> "" Then
Cells(k, "C").Value = Date
Cells(k, "C").NumberFormat = "m/d/yyyy"
Else
Cell.Locked = True
End If
Next
.Protect Password:="10"
Case Is = vbNo
Next
Next
Range("C11:C60").Columns.AutoFit
End With
End If
End Select
Application.EnableEvents = True
End Sub
I'm trying to get this code to automatically do the following :
When cell is empty then information can be entered then display date in adjecent cell after the data is in the cell. And when the data needs to be changed request for password with yes/no vba functions.
I cleaned up your code, though haven't tested if it does what you want it to do, it at least compiles:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim k As Integer
Dim confirm As Integer
Dim cell As Range
If Target.Column = 4 Then
confirm = MsgBox("Do you wish to confirm entry of this data?" _
& vbCrLf & "You'll not be allowed to change it!", vbYesNo, "confirm Entry")
Select Case confirm
Case vbYes
With Me
.Unprotect Password:="10"
.Cells.Locked = False
For k = 10 To 60
If .Cells(k, 4).Value <> "" Then
.Cells(k, 3).Value = Date
.Cells(k, 3).NumberFormat = "m/d/yyyy"
End If
Next
.Cells.Locked = True
.Protect Password:="10"
.Range("C11:C60").Columns.AutoFit
End With
End Select
End If
Application.EnableEvents = True
End Sub
I have been looking for days to solve this and have only come up with half the solution.
What I can do:
I would simply like to have one cell turn green inside with an x inserted when another cells data has the word "Complete" inside it.
What I cannot do:
I would like that same cell that turned green with an x inserted into it when the word "Complete" is changed to "Rework" to stay green with an x.
So Cell A1 is blank then in cell B1 the word "Complete" is added. Then cell A1 changes to green and has an x inside it. If later B1 changes to "Rework" I would like A1 to stay green with the x inside. So I can know that at one time the status of B1 was at one time "Complete"
I have been trying Conditional Formatting with rules but cannot get it to stay. I think the "Stop If True" check box within would be part of the solution but not sure what the code would be.
I already have a different macro running on this sheet so if the answer is a macro I will need it to be added to it. Below is the macro in the sheet already. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count)) Is Nothing Then
If Target.Count < Columns.Count Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim r As Range
For Each r In Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Ideally you'd split this up into separate subs to handle each of the change types, but this should give you an idea:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, r as Range
'skip full-row changes (row insert/delete?)
If Target.Columns.Count = Columns.Count Then Exit Sub
Set rng = Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
Set rng = Intersect(Target, Range("B:B"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
If r.Value = "Complete" Then
With r.Offset(0, -1)
.Value = "x"
.Interior.Color = vbGreen
End With '<<EDIT thanks #BruceWayne
End If
Next r
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
You'll need two worksheet events, and some If statements. The following should help you get started, unless I'm overlooking something.
Dim oldVal as String ' Public variable
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Debug.Print Target.Address
If Target.Cells.Count <> 1 Then Exit Sub
oldVal = Target.Value
End Sub
The above will make note of the oldValue.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newVal As String
newVal = Target.Value
If newVal = oldVal Then
Debug.Print "Same Values"
ElseIf oldVal = "Complete" And newVal = "Rework" Then
Debug.Print "Stay green with X"
ElseIf oldVal = "" And (newVal = "Complete" Or newVal = "complete") Then
Debug.Print "Change cell to Green, add an 'X'"
Target.Interior.ColorIndex = 10
Target.Value = Target.Value & " x"
End If
End Sub
Then, add/tweak those If statements as necessary, and add the color changing/reverting code to the appropriate block.
(There may of course be a better mousetrap, but I think this should get you going).
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