I have a drop-down list in a column B and I want to capture timestamps of changes made to that column based on different options available in drop-down and extract that timestamp to different columns
User can choose from the list and i have a macro that inputs timestamp of any change made.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20180830
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 3
xTimeColumn =
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now()
End If
Next
End If
End If
End Sub
I am looking for a way to modify it, so that once user chooses "In-progress" timestamp is saved in column D, later that cell can be changed into "Closed" and timestamp of that should be presented in column E (respective row) but the value of Column D will stay the same.
I wanna trace timestamp of status changes.
You can use a switch for each of your outputs to determine the column (c), based on your change event, such that:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
dim r as long, c as long
r = target.row
select case lcase(target.value)
case "in-progess"
c = 4
case "closed"
c = 5
case else
c = 0
end select
if c > 0 then cells(r,c).value = now()
end sub
untested code
Related
I have a spreadsheet for inserting values of scores of different teams. Column A has the team names and column B has their scores. The same goes for column C and D. There are 10 teams with 5 in Column A and C. My goal is to code when you enter a score for a team it goes two to the right and when you enter that value, it goes down one and left two. I had that working before, but I had to implement one more thing, and it stopped working. I had to implement that when an invalid score is entered, a non-number, negative number, etc. it would delete itself. I am not sure what I did wrong or what may have led me in the wrong direction.
Here's What I Have
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TeamScore2 As Integer
Dim TeamScore4 As Integer
Select Case Target.Column
Case 2: Target.Offset(0, 2).Select
Case 4: Target.Offset(1, -2).Select
End Select
TeamScore2 = ActiveCell.Offset(0, 2).Value
TeamScore4 = ActiveCell.Offset(1, -2).Value
If TeamScore2 <= -1 Then
ActiveCell.Value = ""
End If
If TeamScore4 <= -1 Then
ActiveCell.Value = ""
End If
End Sub
image of spreadsheet
final statments
I declared two integers and when the selected cell depending on the offset, either (0, 2) or (1, -2) was less than or equal to -1 then the value should be "". Also, I am not sure how I would implement the case that the value is a string. Also, someone said this question was already answered with a link, but I was not able to interpret it as its idea was different than my intentions.
A Worksheet Change: Teams and Scores
In cell B8 you could use something like
=IF(COUNT(B3:B7,D3:D7)=10,"Yes","No")
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const rgAddress As String = "B3:B7,D3:D7"
Const MinNum As Long = 0
Const MaxNum As Long = 100
Dim srg As Range: Set srg = Range(rgAddress)
Dim irg As Range: Set irg = Intersect(srg, Target)
If irg Is Nothing Then Exit Sub
Dim iCell As Range
Dim ValidCell As Range
Dim InvalidCells As Range
Dim iValue As Variant
Dim IsValid
For Each iCell In irg.Cells
iValue = iCell.Value
If VarType(iValue) = vbDouble Then ' number
If iValue = Int(iValue) Then ' whole number
If iValue >= MinNum And iValue <= MaxNum Then ' in range
Set ValidCell = iCell
IsValid = True
End If
End If
End If
If IsValid Then
IsValid = False
Else
If InvalidCells Is Nothing Then
Set InvalidCells = iCell
Else
Set InvalidCells = Union(InvalidCells, iCell)
End If
End If
Next iCell
If InvalidCells Is Nothing Then
Dim ColOffset As Long
ColOffset = srg.Areas(2).Column - srg.Areas(1).Column
If Intersect(ValidCell, srg.Areas(1)) Is Nothing Then
ValidCell.Offset(1, -ColOffset).Select
Else
ValidCell.Offset(, ColOffset).Select
End If
Else
Application.EnableEvents = False
InvalidCells.Value = Empty
Application.EnableEvents = True
InvalidCells.Cells(1).Select
End If
End Sub
I am a beginner in VBA.
I have a Column "A" can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.
Private Sub Worksheet_Change(ByVal Target As Range)
' 040
Const TriggerClm As String = "A" ' change to suit
Const WriteToClm As String = "B" ' the second one is next to this
Dim Rng As Range ' working range
Dim C As Long ' WriteToClm
Dim Criteria() As String ' selected values from TriggerClm
Dim i As Integer ' index to Criteria()
' don't respond to changes of multiple cells such as Paste or Delete
If Target.CountLarge > 1 Then Exit Sub
' respond to changes in cells from row 2 to
' one cell below the last used row in the trigger column
Set Rng = Range(Cells(2, TriggerClm), _
Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
If Not Application.Intersect(Rng, Target) Is Nothing Then
' intentionally all lower case because comparison
' is carried out case insensitive
' First item's date is in WriteToClm
Criteria = Split("impact assessed,ready for retesting", ",")
For i = UBound(Criteria) To 0 Step -1
If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
Next i
' i = -1 if no match was found
If i >= 0 Then
C = Columns(WriteToClm).Column + i
Cells(Target.Row, C).Value = Date
End If
End If
End Sub
You can use something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("A:A"), Target)
If Not rng Is Nothing Then
For Each c in rng.cells
Select Case LCase(c.Value)
Case "impact assessed": c.Offset(0, 1).Value = Date
Case "ready": c.Offset(0, 2).Value = Date
End Select
Next c
End If
End Sub
FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.
I'm trying to update a column with timestamp and another column with updates (which got from a specific cell).
Desired behaviour:
A2 has xy written to it. That change triggers a macro, which puts timestamp in C column at row 2 and the update in D column row 2.
If new update is made in A2: If C2 is not empty, jump to C3 and put timestamp and put update on D3 and so on.
Unfortunately, it puts the first update timestamp and the update to the columns, but if I update again, it doesn't jump and put update there.
Error message and Excel macro
Excel sheet which I try to update.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Integer
Dim xCellRow As Integer
Dim xTimeColumn As Integer
Dim xTimeRow As Integer
Dim xUpdateColumn As Integer
Dim xUpdateRow As Integer
Dim xRow, xCol As Integer
xCellColumn = 2
xCellRow = 10
xTimeColumn = 6
xTimeRow = 2
xUpdateColumn = 7
xUpdateRow = 2
i = 2
xCol = Target.Column
xRow = Target.Row
If Target.Text <> "" Then
If xCol = xCellColumn Then
If xRow = xCellRow Then
Do While Range("Munka1").Cells(i, xTimeColumn).Value <> ""
i = i + 1
Loop
Cells(i, xTimeColumn) = Now()
Cells(i, xUpdateColumn) = Target.Value
End If
End If
End If
End Sub
Please try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumn As Long
Dim xCellRow As Long
Dim xTimeColumn As Long
Dim xUpdateColumn As Long
Dim SupervisedArea As Range
Dim i As Integer
xCellColumn = 2
xCellRow = 10
xTimeColumn = 6
xUpdateColumn = 7
If Target.Text <> "" Then
' If any changed value in the whole column should generate a new data pair:
'Set SupervisedArea = Intersect(Target, Me.Columns(xCellColumn))
' If only one cell should be supervised:
Set SupervisedArea = Intersect(Target, Me.Cells(xCellRow, xCellColumn))
If Not SupervisedArea Is Nothing Then
i = 2
Do While Me.Cells(i, xTimeColumn).Value <> ""
i = i + 1
Loop
Application.EnableEvents = False
Me.Cells(i, xTimeColumn) = Now()
Me.Cells(i, xUpdateColumn) = Target.Value
Application.EnableEvents = True
End If
End If
End Sub
I struggling to work out the logic to this so any help would be appreciated!
I have a sheet with names and dates, on each row (in the example column D to F) it needs to find the greatest date and then add a date to a column (column C). I can get this to work on a single test row, but I need it to work when there is a change on any row.
B C D E F
Name Due Date Date 1 Date 2 Date 3
Dave 01-01-20 01-01-14 01-01-17
Sarah 01-01-21 01-02-11 01-02-15 01-02-18
The code I have so far is:
LastRow = wsCB.Cells(Rows.Count, "C").End(xlUp).Row
rowcount = 12
Max_date = Application.WorksheetFunction.Max(wsCB.Range(wsCB.Cells(rowcount, 5), wsCB.Cells(rowcount, 10)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
wsCB.Cells(12, 4) = DueDate
I have set it to call on a Worksheet_Change. I have tried various loops trying to use xlup but I'm not sure this is the right way to go about it as I need the value to be updated when the user has typed in a new date for someone. I can't quite work out how to scale this single line example to the whole sheet.
The data won't be massive, however there will be 5 sheets like this with up to a maximum of 70 names on each sheet.
I'm still quite new to VBA so any advice would be very helpful!
The following VBA code should achieve your desired results:
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 4, 5, 6 'if user entered data in columns D to F
Max_date = Application.WorksheetFunction.Max(Range(Cells(Target.Row, 4), Cells(Target.Row, 6)))
'get the max value in row from column D to F (4 to 6)
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(Target.Row, 3) = DueDate
End Select
End Sub
Try this.
You'll just need to adjust columns to fit your needs
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MaxDate As Date, DueDate As Date
Dim CurRow As Long
Dim Ws As Worksheet
Set Ws = Target.Parent
CurRow = Target.Row
With Ws
MaxDate = CDate(Application.WorksheetFunction.Max(.Range(.Cells(CurRow, "D"),.Cells(CurRow, "F"))))
DueDate = DateAdd("yyyy", 3, MaxDate)
Application.EnableEvents = False
.Cells(CurRow, 3) = DueDate
Application.EnableEvents = True
End With
End Sub
My suggested code for your problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xCellColumnD As Long
Dim xCellColumnE As Long
Dim xCellColumnF As Long
Dim xDueColumn As Long
Dim xRow As Long, xCol As Long
xCellColumnD = 4
xCellColumnE = 5
xCellColumnF = 6
xDueColumn = 3
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumnD Or xCol = xCellColumnE Or xCol = xCellColumnF Then
Max_date = Application.WorksheetFunction.Max(Range(Cells(xRow, 4), Cells(xRow, 6)))
Max_date = CDate(Max_date)
DueDate = DateAdd("yyyy", 3, Max_date)
Cells(xRow, xDueColumn) = DueDate
End If
End If
End Sub
I suggest to use Intersect in combination with a loop over the Target range so you are a bit more save against pasting a whole range of values.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Target.Parent
If Not Intersect(Target, ws.Range("D:F")) Is Nothing Then
Dim MaxDate As Double
Dim DueDate As Variant
Dim iRow As Long
For iRow = Target.Row To Target.Row + Target.Rows.Count - 1
On Error Resume Next
MaxDate = Application.WorksheetFunction.Max(ws.Range(ws.Cells(iRow, "D"), ws.Cells(iRow, "F")))
If Err.Number <> 0 Then
DueDate = "#VALUE!"
ElseIf MaxDate = 0 Then
DueDate = vbNullString 'remove date if no dates
Else
DueDate = DateAdd("yyyy", 3, MaxDate)
End If
On Error GoTo 0
Application.EnableEvents = False 'prevents triggering change event again
ws.Cells(iRow, "C").Value = DueDate
Application.EnableEvents = True
Next iRow
End If
End Sub
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.