Jul 15 2021 10:22 AM
Hello,
I have a column (A) with eight different text drop down options. I need a code that will allow me to track each time the drop down is changed to a different option. I want each change to be tracked in a different cell so that I can see how each line has progressed - e.g. from Received to Query to Invalid etc.
I have the following code which works to remember the last value of the cell from column A, but I cannot figure out how to make it work for my needs:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, 49)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("A:A"))
End If
Label1:
Set xRg = Intersect(Target, Range("A:A"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
Essentially, I want every change made in column A tracked in column AW, AX, AY and so on. There will be no more than 10 changes to an individual cell in column A.
Thanks.
Jul 19 2021 01:46 AM
@Shouler This code appears to work:
Option Explicit
Private selRng As Range
Private selPrevValue As Variant
Private Sub Worksheet_Activate()
If Target.Cells.Count = 1 Then
Set selRng = Selection
selPrevValue = selRng.Value2
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim selCurValue As Variant
On Error GoTo ErrLoc 'added to ensure events are always turned back on
If Target.Cells.Count = 1 Then
Application.EnableEvents = False
If selRng Is Nothing Then
Set selRng = Target
selCurValue = selRng.Value2
Application.Undo
selPrevValue = selRng.Value2
Target.Value = selCurValue
If selPrevValue <> selCurValue Then
Storeprevvalue selRng, selPrevValue
End If
Else
If selPrevValue <> Target.Value Then
Storeprevvalue selRng, selPrevValue
End If
selPrevValue = Target.Value2
Set selRng = Target
End If
End If
ErrLoc:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count = 1 Then
Set selRng = Selection
selPrevValue = selRng.Value2
End If
End Sub
Sub Storeprevvalue(rng As Range, prevValue As Variant)
If Not IsEmpty(prevValue) Then
Me.Cells(rng.Row, Me.Columns.Count).End(xlToLeft).Offset(, 1).Value = prevValue
End If
End Sub
Jul 22 2021 08:40 AM
This is helpful and kind of works, but it records a change to every cell in that row, when I need it to track only the changes in the first cell. Is there a way to resolve this? Thanks.
Jul 23 2021 04:32 AM
@Shouler Like this (fixed a small bug too):
Option Explicit
Private selRng As Range
Private selPrevValue As Variant
Private Sub Worksheet_Activate()
If Intersect(Me.Range("A:A"), Selection) Is Nothing Then Exit Sub
If Selection.Cells.Count = 1 Then
Set selRng = Selection
selPrevValue = selRng.Value2
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim selCurValue As Variant
On Error GoTo ErrLoc 'added to ensure events are always turned back on
If Intersect(Me.Range("A:A"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count = 1 Then
Application.EnableEvents = False
If selRng Is Nothing Then
Set selRng = Target
selCurValue = selRng.Value2
Application.Undo
selPrevValue = selRng.Value2
Target.Value = selCurValue
If selPrevValue <> selCurValue Then
Storeprevvalue selRng, selPrevValue
End If
Else
If selPrevValue <> Target.Value Then
Storeprevvalue selRng, selPrevValue
End If
selPrevValue = Target.Value2
Set selRng = Target
End If
End If
ErrLoc:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Me.Range("A:A"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count = 1 Then
Set selRng = Selection
selPrevValue = selRng.Value2
End If
End Sub
Sub Storeprevvalue(rng As Range, prevValue As Variant)
If Not IsEmpty(prevValue) Then
Me.Cells(rng.Row, Me.Columns.Count).End(xlToLeft).Offset(, 1).Value = prevValue
End If
End Sub