I see, there is always a way around these things. I added your sort line to the Worksheet_Change event and added an index column (which I have hidden) in column C of Sheet1. I have also made the only place the target range is defined to the Workbook_Open sub.
As I can't see what you have in column A - with your sort, you may need to add that back in, I have made it only sort by one column to make it work with the example. I can help with this if you see this as an option.
ThisWorkbook module:
Option Explicit
Private Sub Workbook_Open()
Dim endRow As Long
Set tRng = Range("C5:E14") ' whole target range with index column
With Sheets("UNDO") ' all code below that starts with a full stop (period in USA) will reference the UNDO sheet
endRow = .Cells(Rows.Count, 1).End(xlUp).Row ' set end row of the UNDO sheet
If endRow > 1 Then ' check if endRow is the header row, if it is then don't bother clearing the UNDO sheet
.Range("A2:D" & endRow).ClearContents ' clear contents for every cell with data under the headings of the UNDO sheet
End If
End With
End Sub
Sheet1 module:
Option Explicit
Dim i As Long
Private Sub Worksheet_Change(ByVal Target As Range)
' Code from: p45cal - www.vbaexpress.com - 03/12/2023
' Edited by: georgiboy - www.vbaexpress.com - 06/12/2023
Dim rngToProcess As Range, sNewValue, sOldValue
Dim rCell As Range, nr As Long
Set rngToProcess = Intersect(Target, Application.Index(tRng, , 2)) ' create a range from cells edited
If Not rngToProcess Is Nothing Then ' check if the above range is empty
Application.EnableEvents = False ' switch off events so there is not an infinite loop
sNewValue = Target.Value ' get the value that was just entered
sOldValue = Target.Offset(, 1).Value ' get the previous value
Application.UNDO ' undo your last entry
Target.Offset(, 1).Value = Target.Value ' write the previous value to the cell to the right of target
i = i + 1 ' increment the instance, used for the UNDO sub
For Each rCell In rngToProcess ' loop through the cells in the target range
With Sheets("UNDO") ' all code below that starts with a full stop (period in USA) will reference the UNDO sheet
nr = .Cells(Rows.Count, 1).End(xlUp).Row + 1 ' get the next blank ro of the UNDO sheet
.Range("A" & nr) = i ' write the instance number to the UNDO sheet
.Range("B" & nr) = rCell.Offset(, -1) ' write the target index to the UNDO sheet
.Range("C" & nr) = rCell.Offset(, 1).Value ' write what was the current value to the UNDO sheet
.Range("D" & nr) = sOldValue ' write the existing previous value to the UNDO sheet
End With
Next rCell
Target.Value = sNewValue ' write back the latest value you entered
tRng.Sort tRng(1, 2), xlAscending, , , xlDescending ' sort the sort range
Application.EnableEvents = True ' switch events back on
End If
End Sub
Module 1:
Option Explicit
Public tRng As Range
Sub UNDO()
' Code from: georgiboy - www.vbaexpress.com - 06/12/2023
Dim wsU As Worksheet, ws1 As Worksheet
Dim x As Long, wsUend As Long, inst As Long
Dim rCell As Range, indR As Long
Application.EnableEvents = False ' switch off events so that the code below does not trigger the Worksheet_Change event
Set wsU = Sheets("UNDO") ' the hidden sheet named UNDO
Set ws1 = Sheets("Sheet1") ' the sheet that will be undone
wsUend = wsU.Cells(Rows.Count, 1).End(xlUp).Row ' end row of sheet UNDO
On Error GoTo JumpOut ' if the next line of code produces an error then it will go to JumpOut at the bottom of this sub
inst = wsU.Range("A" & wsUend).Value ' latest instance that was added to the UNDO sheet
On Error GoTo 0 ' switch error state back on
For x = wsUend To 2 Step -1 ' loop backwards through the UNDO sheet
If wsU.Range("A" & x) = inst Then ' check if the current row on UNDO sheet was the lates instance
indR = Application.Index(tRng, , 1).Find(wsU.Range("B" & x).Value).Row ' find the index number on sheet1
Set rCell = ws1.Range("D" & indR) ' create a reference range to the cell on ws1
rCell.Value = wsU.Range("C" & x).Value ' write the previous value back to ws1
rCell.Offset(, 1) = wsU.Range("D" & x).Value ' write the previous previous value back to ws1
wsU.Range("A" & x & ":D" & x).ClearContents ' empty the row from the UNDO sheet, this allows you to have more undo's
Else
Exit For ' jump out as was not the last instance
End If
Next x
Application.EnableEvents = True ' switch events back on
Exit Sub
JumpOut:
Application.EnableEvents = True ' switch events back on
MsgBox "Nothing to undo", vbInformation, "UNDO"
End Sub
Reply With Quote
Originally Posted by Rob5060
