VBA to take value of cell before changed

[bumbum2812]

Hi Experts,

I would love to have a vba code to copy the old value from column status to column previous status when i input new value to column status
Thank you.

 

[Legacy 456155]

This is thrown together, but seems to work just fine. Replace Sheet1 with the correct codename of your worksheet. Name the range you will be tracking, "LogValuesRange."

If you need to see an example, see "Range Value History.xlsm" in this folder.

In your workbook class:

Private Sub Workbook_Open()
    Sheet1.FetchCurrentValues
End Sub

In your worksheet.

Private d As Dictionary

Public Sub FetchCurrentValues()
    Dim r As Range
    Set d = New Dictionary
    For Each r In Range("LogValuesRange")
        d.Add r.Address, r.Value
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range
    If Not Intersect(Target, Range("LogValuesRange")) Is Nothing Then
        For Each r In Intersect(Target, Range("LogValuesRange"))
            r.Offset(, 1) = d(r.Address)
            d(r.Address) = r.Value
        Next
    End If
End Sub

 

[bumbum2812]

Hi dataluver,

Is there anyway to repalce active sheet instead of Sheet1 in Private Sub Workbook_Open()
My workbook have multiple sheet and dont have a fixed name.

 

[Dossfm0q]

another option

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Cll As Range
Dim OldValue As String, NewValue As String
    Application.ScreenUpdating = False
        Application.EnableEvents = False
        On Error Resume Next
        If Target.Cells.Count = 1 Then
            Application.Undo
            OldValue = Target.Value
            Application.Undo
            Target.Offset(0, 1) = (OldValue)
            
            Else' not function with copy/paste multi range
            'Application.Undo
            'For Each Rng In Target.Offset(0, 1): For Each Cll In Target
            'If Rng.Row = Cll.Row Then Rng = Cll
            'Next: Next
            'Application.Undo
            
            Application.Undo
             OldValue = Range(Target.Address).Value
            Application.Undo
            Range(Target.Offset(0, 1).Address) = (OldValue)
          
            End If
         On Error GoTo 0
        Application.EnableEvents = True
    Application.ScreenUpdating = True
  
End Sub

 

[Dossfm0q]

hi to be worksheet module

 

[Dossfm0q]

Try Now Please
into Worksheet Module

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Cll As Range
 Dim OldValue As Variant
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If Not Intersect(Target, Columns("A")) Is Nothing Then
        On Error Resume Next
        If Target.Cells.Count = 1 Then
                Application.Undo
                OldValue = Target.Value
                Application.Undo
                Target.Offset(0, 1) = (OldValue)
          
            Else
            
                Application.Undo
                OldValue = Range(Target.Address).Value
                Application.Undo
                Range(Target.Offset(0, 1).Address) = (OldValue)
                
                Application.Wait (Now + TimeValue("0:00:01")) ' Now ok
                
            End If
         On Error GoTo 0
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
End Sub

 

[Legacy 456155]

I think Doss' answer is better than mine. I would add a few lines of code to set the current selection. See below.
Doss, what is this line for?
Application.Wait ?
Doss, can you adapt the code to work with multiple worksheets by using the workbook level event:
Private Sub Workbook_SheetChange...
If not, I'll help out further.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range, Cll As Range
    Dim OldValue As Variant
    Dim CurrentSelection
    Set CurrentSelection = Selection
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If Not Intersect(Target, Columns("A")) Is Nothing Then
        On Error Resume Next
        If Target.Cells.Count = 1 Then
                Application.Undo
                OldValue = Target.Value
                Application.Undo
                Target.Offset(0, 1) = (OldValue)
          
            Else
            
                Application.Undo
                OldValue = Range(Target.Address).Value
                Application.Undo
                Range(Target.Offset(0, 1).Address) = (OldValue)
                
                'Application.Wait (Now + TimeValue("0:00:01")) ' Now ok
                
            End If
         On Error GoTo 0
    End If
    
    CurrentSelection.Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
End Sub

 

[Dossfm0q]

Thank you
MR: [B]dataluver[/B] For your advice and advanced development. Very nice edit

Now work very will
As your Advice
Into WorkBook Module

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim Rng As Range, Cll As Range
    Dim OldValue As Variant
    Dim CurrentSelection
    Set CurrentSelection = Selection
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If Not Intersect(Target, Columns("A")) Is Nothing Then
        On Error Resume Next
        If Target.Cells.Count = 1 Then
                Application.Undo
                OldValue = Target.Value
                Application.Undo
                Target.Offset(0, 1) = (OldValue)
          
            Else
            
                Application.Undo
                OldValue = Range(Target.Address).Value
                Application.Undo
                Range(Target.Offset(0, 1).Address) = (OldValue)
                
                
            End If
         On Error GoTo 0
    End If
    
    CurrentSelection.Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
 
End Sub

 

[bumbum2812]

Thank you dataluver & Dossfm0q for your kind support. Have a nice day !