Here is the situation
Columns A through G are designed as drop down lists (data validation): Name, Number, ID, Phone, etc. Upon arrival to the office, each employee must fill their information into each cell of the row, in columns A to G.
What I want from a VBA code:
Only when each cell is filled in A:G, the date and time is stamped in the corresponding cell, in column H. It is permanent. It doesn't change ever. And once the date is stamped, the cells Columns A:G are locked as well.
My coding so far:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Target.Offset(0,1) = Now
End If
End Sub
This timestamp only works when cells in column A are changed :(
Should I be using a "case select" statement?
Is this what you are trying? (TRIED AND TESTED)
Option Explicit
'~~> Change this to the relevant password
Const MYPASSWORD As String = "BlahBlah"
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
On Error GoTo Whoa
Application.EnableEvents = False
Dim rng As Range
Dim nRow As Long
nRow = Target.Row
Set rng = Range("A" & nRow & ":G" & nRow)
'~~> Check if all cell from A-G are filled and
'~~> There is no time stamp already there
If Application.WorksheetFunction.CountA(rng) = 7 _
And Len(Trim(Range("H" & nRow).Value)) = 0 Then
ActiveSheet.Unprotect MYPASSWORD
Range("H" & nRow).Value = Now
Range("A" & nRow & ":H" & nRow).Locked = True
ActiveSheet.Protect MYPASSWORD
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Related
I'm using the following VBA module to create a Timestamp UDF, which stamps the date once the referenced cell reads "Done":
Function Timestamp(Reference As Range)
If Reference.Value = "Done" Then
Timestamp = Format(Date, "ddd dd mmm")
Else
Timestamp = ""
End If
End Function
The date stays the same even after refreshing / closing and opening the workbook as long as the referenced cell still reads "Done"; however if someone accidentally changes the referenced cell then the date is reset.
I need a VBA code to convert the formula to value once it has calculated, so the date will always stay the same. The solution needs to be automatic rather than manual and I can't enable iterative formulas on this workbook because it's used by multiple users. Any help much appreciated!
You can use the Worksheet Change event for that:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedCells As Range
Set AffectedCells = Intersect(Target, Me.Range("A:A")) ' Range A:A is the range we observe for 'done'
If AffectedCells Is Nothing Then Exit Sub
Dim Cell As Range
For Each Cell In AffectedCells
If Cell.Value = "done" Then
Dim UpdateTimestamp As Boolean
UpdateTimestamp = True
If Range("B" & Cell.Row).Value <> vbNullString Then
UpdateTimestamp = MsgBox("Timestamp exists do you want to update it?", vbQuestion + vbYesNo) = vbYes
End If
If UpdateTimestamp Then
Me.Range("B" & Cell.Row).Value = Format$(Date, "ddd dd mmm")
End If
End If
Next Cell
End Sub
// Edit according comment:
If you want to check multiple ranges for different things you need to slightly change your code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim ObservedRangeA As Range
Set ObservedRangeA = Intersect(Target, Me.Range("A:A")) ' Range A:A is the range we observe for 'done'
If Not ObservedRangeA Is Nothing Then
For Each Cell In ObservedRangeA
If Cell.Value = "done" And Range("B" & Cell.Row).Value = vbNullString Then
Me.Range("B" & Cell.Row).Value = Format$(Date, "ddd dd mmm")
End If
Next Cell
End If
Dim ObservedRangeB As Range
Set ObservedRangeB = Intersect(Target, Me.Range("C:C")) ' Range C:C is the range we observe for ""
If Not ObservedRangeB Is Nothing Then
For Each Cell In ObservedRangeB
If Cell.Value = "" And Range("B" & Cell.Row).Value = vbNullString Then
Me.Range("B" & Cell.Row).Value = Format$(Date, "ddd dd mmm")
End If
Next Cell
End If
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
Good day, i got a set of code as below:
Dim oval
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oval = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2:C1048576")) Is Nothing Then
Range("G" & Target.Row) = Now()
Range("H" & Target.Row) = oval
End If
End Sub
This is supposed to update column "G" with current date and time while column "H" with previous content in "C" should a change detected in column "C".
While this code is working, i got an issue whereby deleting a row of data in the middle of the table will shift the lower row up to the deleted row but it will update the column "G" and "H" as well.
is there a way to prevent that? thank you.
This will solve some of your problems:
Dim oval
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
oval = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C1048576")) Is Nothing Then
Application.EnableEvents = False
Range("G" & Target.Row) = Now()
Range("H" & Target.Row) = oval
Application.EnableEvents = True
End If
End Sub
I would get rid of the public variable and Worksheet_SelectionChange event macro. Application.Undo can be applied within the Worksheet_Change event macro after recording the changed values.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C:C")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim rng As Range, vCEEs As Variant
vCEEs = Range(Cells(1, "C"), Cells(Rows.Count, "C").End(xlUp)).Value
Application.Undo
For Each rng In Intersect(Target, Range("C:C"))
Range("G" & rng.Row) = Now()
Range("H" & rng.Row) = Range("C" & rng.Row)
Range("C" & rng.Row) = vCEEs(rng.Row, 1)
Next rng
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
This should survive pasting multiple values into column C but you risk losing values pasted into other columns.
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 very new to Excel VBA and I’m an trying to write some code that achieves the following:
When a cell is clicked in column A that contained the text “123” or “xyz” the cell in the same row but in column B records the current time, and the cell in the same row but in column C records the username of the person who clicked it.
The following is the code I am currently using:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNum As Long
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
If Not Target.Value.Text = 123 Then Exit Sub
If Not Target.Value.Text = XYZ Then Exit Sub
RowNum = Target.Row
Range("B" & RowNum).Value = Date
Range("C" & RowNum).Value = Environ("UserName")
End Sub
Currently I a variable not defined error on XYZ, however I feel as if there is quite a lot of other issues with my code.
You were not too far. I think this should work fine:
Private Sub Worksheet_Change(ByVal Target As Range) '<-- event is change, non selection change
Dim RowNum As Long
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
If (Target.Value = "123") Or (Target.Value = "xyz") Then '<-- if the value is either "xyz" or "123"
RowNum = Target.Row
Range("B" & RowNum).Value = Now() '<-- current time in column B
Range("C" & RowNum).Value = Environ("UserName") '<-- username in column C
End If
End Sub