Excel VBA to Store Previous Cell Values

%3CLINGO-SUB%20id%3D%22lingo-sub-2553513%22%20slang%3D%22en-US%22%3EExcel%20VBA%20to%20Store%20Previous%20Cell%20Values%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2553513%22%20slang%3D%22en-US%22%3E%3CP%3EHello%2C%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EI%20have%20a%20column%20(A)%20with%20eight%20different%20text%20drop%20down%20options.%26nbsp%3B%20I%20need%20a%20code%20that%20will%20allow%20me%20to%20track%20each%20time%20the%20drop%20down%20is%20changed%20to%20a%20different%20option.%20I%20want%20each%20change%20to%20be%20tracked%20in%20a%20different%20cell%20so%20that%20I%20can%20see%20how%20each%20line%20has%20progressed%20-%20e.g.%20from%20Received%20to%20Query%20to%20Invalid%20etc.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EI%20have%20the%20following%20code%20which%20works%20to%20remember%20the%20last%20value%20of%20the%20cell%20from%20column%20A%2C%20but%20I%20cannot%20figure%20out%20how%20to%20make%20it%20work%20for%20my%20needs%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPrivate%20Sub%20Worksheet_Change(ByVal%20Target%20As%20Range)%3CBR%20%2F%3EDim%20I%20As%20Long%3CBR%20%2F%3EDim%20xCell%20As%20Range%3CBR%20%2F%3EDim%20xDCell%20As%20Range%3CBR%20%2F%3EDim%20xHeader%20As%20String%3CBR%20%2F%3EDim%20xCommText%20As%20String%3CBR%20%2F%3EOn%20Error%20Resume%20Next%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20False%3CBR%20%2F%3EApplication.EnableEvents%20%3D%20False%3CBR%20%2F%3ExHeader%20%3D%20%22Previous%20value%20%3A%22%3CBR%20%2F%3Ex%20%3D%20xDic.Keys%3CBR%20%2F%3EFor%20I%20%3D%200%20To%20UBound(xDic.Keys)%3CBR%20%2F%3ESet%20xCell%20%3D%20Range(xDic.Keys(I))%3CBR%20%2F%3ESet%20xDCell%20%3D%20Cells(xCell.Row%2C%2049)%3CBR%20%2F%3ExDCell.Value%20%3D%20%22%22%3CBR%20%2F%3ExDCell.Value%20%3D%20xDic.Items(I)%3CBR%20%2F%3ENext%3CBR%20%2F%3EApplication.EnableEvents%20%3D%20True%3CBR%20%2F%3EApplication.ScreenUpdating%20%3D%20True%3CBR%20%2F%3EEnd%20Sub%3CBR%20%2F%3EPrivate%20Sub%20Worksheet_SelectionChange(ByVal%20Target%20As%20Range)%3CBR%20%2F%3EDim%20I%2C%20J%20As%20Long%3CBR%20%2F%3EDim%20xRgArea%20As%20Range%3CBR%20%2F%3EOn%20Error%20GoTo%20Label1%3CBR%20%2F%3EIf%20Target.Count%20%26gt%3B%201%20Then%20Exit%20Sub%3CBR%20%2F%3EApplication.EnableEvents%20%3D%20False%3CBR%20%2F%3ESet%20xDependRg%20%3D%20Target.Dependents%3CBR%20%2F%3EIf%20xDependRg%20Is%20Nothing%20Then%20GoTo%20Label1%3CBR%20%2F%3EIf%20Not%20xDependRg%20Is%20Nothing%20Then%3CBR%20%2F%3ESet%20xDependRg%20%3D%20Intersect(xDependRg%2C%20Range(%22A%3AA%22))%3CBR%20%2F%3EEnd%20If%3CBR%20%2F%3ELabel1%3A%3CBR%20%2F%3ESet%20xRg%20%3D%20Intersect(Target%2C%20Range(%22A%3AA%22))%3CBR%20%2F%3EIf%20(Not%20xRg%20Is%20Nothing)%20And%20(Not%20xDependRg%20Is%20Nothing)%20Then%3CBR%20%2F%3ESet%20xChangeRg%20%3D%20Union(xRg%2C%20xDependRg)%3CBR%20%2F%3EElseIf%20(xRg%20Is%20Nothing)%20And%20(Not%20xDependRg%20Is%20Nothing)%20Then%3CBR%20%2F%3ESet%20xChangeRg%20%3D%20xDependRg%3CBR%20%2F%3EElseIf%20(Not%20xRg%20Is%20Nothing)%20And%20(xDependRg%20Is%20Nothing)%20Then%3CBR%20%2F%3ESet%20xChangeRg%20%3D%20xRg%3CBR%20%2F%3EElse%3CBR%20%2F%3EApplication.EnableEvents%20%3D%20True%3CBR%20%2F%3EExit%20Sub%3CBR%20%2F%3EEnd%20If%3CBR%20%2F%3ExDic.RemoveAll%3CBR%20%2F%3EFor%20I%20%3D%201%20To%20xChangeRg.Areas.Count%3CBR%20%2F%3ESet%20xRgArea%20%3D%20xChangeRg.Areas(I)%3CBR%20%2F%3EFor%20J%20%3D%201%20To%20xRgArea.Count%3CBR%20%2F%3ExDic.Add%20xRgArea(J).Address%2C%20xRgArea(J).Formula%3CBR%20%2F%3ENext%3CBR%20%2F%3ENext%3CBR%20%2F%3ESet%20xChangeRg%20%3D%20Nothing%3CBR%20%2F%3ESet%20xRg%20%3D%20Nothing%3CBR%20%2F%3ESet%20xDependRg%20%3D%20Nothing%3CBR%20%2F%3EApplication.EnableEvents%20%3D%20True%3CBR%20%2F%3EEnd%20Sub%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EEssentially%2C%20I%20want%20every%20change%20made%20in%20column%20A%20tracked%20in%20column%20AW%2C%20AX%2C%20AY%20and%20so%20on.%26nbsp%3B%20There%20will%20be%20no%20more%20than%2010%20changes%20to%20an%20individual%20cell%20in%20column%20A.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThanks.%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2553513%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2561274%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20VBA%20to%20Store%20Previous%20Cell%20Values%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2561274%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F1104621%22%20target%3D%22_blank%22%3E%40Shouler%3C%2FA%3E%26nbsp%3BThis%20code%20appears%20to%20work%3A%3C%2FP%3E%0A%3CPRE%20class%3D%22lia-code-sample%20language-applescript%22%3E%3CCODE%3EOption%20Explicit%0A%0APrivate%20selRng%20As%20Range%0APrivate%20selPrevValue%20As%20Variant%0A%0APrivate%20Sub%20Worksheet_Activate()%0A%20%20%20%20If%20Target.Cells.Count%20%3D%201%20Then%0A%20%20%20%20%20%20%20%20Set%20selRng%20%3D%20Selection%0A%20%20%20%20%20%20%20%20selPrevValue%20%3D%20selRng.Value2%0A%20%20%20%20End%20If%0AEnd%20Sub%0A%0APrivate%20Sub%20Worksheet_Change(ByVal%20Target%20As%20Range)%0A%20%20%20%20Dim%20selCurValue%20As%20Variant%0A%20%20%20%20On%20Error%20GoTo%20ErrLoc%20%20%20%20'added%20to%20ensure%20events%20are%20always%20turned%20back%20on%0A%20%20%20%20If%20Target.Cells.Count%20%3D%201%20Then%0A%20%20%20%20%20%20%20%20Application.EnableEvents%20%3D%20False%0A%20%20%20%20%20%20%20%20If%20selRng%20Is%20Nothing%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20Set%20selRng%20%3D%20Target%0A%20%20%20%20%20%20%20%20%20%20%20%20selCurValue%20%3D%20selRng.Value2%0A%20%20%20%20%20%20%20%20%20%20%20%20Application.Undo%0A%20%20%20%20%20%20%20%20%20%20%20%20selPrevValue%20%3D%20selRng.Value2%0A%20%20%20%20%20%20%20%20%20%20%20%20Target.Value%20%3D%20selCurValue%0A%20%20%20%20%20%20%20%20%20%20%20%20If%20selPrevValue%20%26lt%3B%26gt%3B%20selCurValue%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20Storeprevvalue%20selRng%2C%20selPrevValue%0A%20%20%20%20%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20%20%20%20%20Else%0A%20%20%20%20%20%20%20%20%20%20%20%20If%20selPrevValue%20%26lt%3B%26gt%3B%20Target.Value%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20Storeprevvalue%20selRng%2C%20selPrevValue%0A%20%20%20%20%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20%20%20%20%20%20%20%20%20selPrevValue%20%3D%20Target.Value2%0A%20%20%20%20%20%20%20%20%20%20%20%20Set%20selRng%20%3D%20Target%0A%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20End%20If%0AErrLoc%3A%0A%20%20%20%20Application.EnableEvents%20%3D%20True%0AEnd%20Sub%0A%0APrivate%20Sub%20Worksheet_SelectionChange(ByVal%20Target%20As%20Range)%0A%20%20%20%20If%20Target.Cells.Count%20%3D%201%20Then%0A%20%20%20%20%20%20%20%20Set%20selRng%20%3D%20Selection%0A%20%20%20%20%20%20%20%20selPrevValue%20%3D%20selRng.Value2%0A%20%20%20%20End%20If%0AEnd%20Sub%0A%0ASub%20Storeprevvalue(rng%20As%20Range%2C%20prevValue%20As%20Variant)%0A%20%20%20%20If%20Not%20IsEmpty(prevValue)%20Then%0A%20%20%20%20%20%20%20%20Me.Cells(rng.Row%2C%20Me.Columns.Count).End(xlToLeft).Offset(%2C%201).Value%20%3D%20prevValue%0A%20%20%20%20End%20If%0AEnd%20Sub%0A%3C%2FCODE%3E%3C%2FPRE%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2575821%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20VBA%20to%20Store%20Previous%20Cell%20Values%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2575821%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F22322%22%20target%3D%22_blank%22%3E%40Jan%20Karel%20Pieterse%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThis%20is%20helpful%20and%20kind%20of%20works%2C%20but%20it%20records%20a%20change%20to%20every%20cell%20in%20that%20row%2C%20when%20I%20need%20it%20to%20track%20only%20the%20changes%20in%20the%20first%20cell.%26nbsp%3B%20Is%20there%20a%20way%20to%20resolve%20this%3F%26nbsp%3B%20Thanks.%3C%2FP%3E%3C%2FLINGO-BODY%3E
New Contributor

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.

3 Replies

@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

@Jan Karel Pieterse 

 

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.

@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