How to allow multiple successive undos in excel vba? - excel

Question

I have an excel workbook that needs to allow the user to undo multiple changes within a worksheet. I have searched online in every forum that I can think of and have not been able to find an answer for this. I realize that there is an issue with the undo issue in excel when macro's are run, and have been able to handle this using code derived from here.
This is my current process:
Create global variables to hold the initial state of the workbook, and the changes. Code is as follows:
Private Type SaveRange
Val As Variant
Addr As String
End Type
Private OldWorkbook As Workbook
Private OldSheet As Worksheet
Private OldSelection() As SaveRange
Private OldSelectionCount As Integer
Private InitialState() As SaveRange
Private InitialStateCount As Integer
Get the initial state of the workbook by building an array (InitialState) holding the values of all the cells in the Workbook_Open sub. Code is as follows:
Private Sub Workbook_Open()
GetInitialCellState
End Sub
Private Sub GetInitialCellState()
Dim i As Integer, j As Integer, count As Integer
Dim cellVal As String
Dim sampID As Range, cell As Range
Dim e1664 As Workbook
Dim rawData As Worksheet
Dim table As Range
Dim LastRow As Integer, LastCol As Integer
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
LastCol = Worksheets("Raw_Data").UsedRange.Columns.count
Set e1664 = ThisWorkbook
Set rawData = e1664.Sheets("Raw_Data")
Set sampID = rawData.Range("SAMPLEID").Offset(1)
Set table = rawData.Range(sampID, "R" & LastRow)
i = 0
j = 0
count = 0
ReDim InitialState(i)
For i = 0 To (LastRow - sampID.Row)
For j = 0 To LastCol
ReDim Preserve InitialState(count)
InitialState(count).Addr = sampID.Offset(i, j).address
InitialState(count).Val = sampID.Offset(i, j).Value
count = count + 1
Next j
Next i
InitialStateCount = count - 1
End Sub
When a value is entered into a cell, store the value entered into another array (OldSelection) holding the value entered. This is done in the Workbook_Change sub. The important parts here are the Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value) and Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState" pieces which are shown in numbers 4 and 5 below. Code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, InWtRange As Boolean
Dim y As Integer, x As Integer, count As Integer
Dim LastRow As Integer
'This saves the changed values of the cells
Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value)
try:
y = Me.Range("SampleID").Row
If Target.Column > 5 And Target.Column < 8 Then
If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then
If Range("A" & Target.Row + 1).Value <> "" Then
Range(Target.address).Offset(1).Value = Range(Target.address).Value
End If
End If
Else
'If initial pan weight add start date
If Target.Column = 8 Then
If Target.Cells.Text <> "" Then
If Not IsNumeric(Target.Cells.Value) Then
GoTo Finally
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS")
Application.EnableEvents = True
End If
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = ""
Application.EnableEvents = True
End If
End If
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
For Each cell In Target.Cells
'Debug.Print Target.Cells.Address
If cell.Value <> "" Then
If Not IsNumeric(cell.Value) Then GoTo Finally
Select Case cell.Column
Case 9, 11, 13
Application.EnableEvents = False
If CalcHEM(cell.Row - y, cell.Column) Then
End If
Application.EnableEvents = True
Case Else
'Do nothing yet
End Select
'Cells(Target.Row + 1, Target.Column).Select
End If
Next
'This will allow the changed values to be undone
Application.OnUndo "Undo the last action", "GI.OR.E1664.20150915_DRAFT.xlt!Sheet1.RevertState"
Finally:
If Application.EnableEvents = False Then Application.EnableEvents = True
Exit Sub
Catch:
MsgBox "An error has occurred in the code execution." & vbNewLine _
& "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC"
Resume Finally
End Sub
The SaveState Sub will save add to the OldSelection array, any values that have changed. Code is as follows:
Private Sub SaveState(count As Integer, Addr As String, Val As Double)
Dim i As Integer
Dim cell As Range
If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub
ReDim Preserve OldSelection(count)
Set OldWorkbook = ActiveWorkbook
Set OldSheet = ActiveSheet
For Each cell In Selection
OldSelection(count).Addr = Addr
OldSelection(count).Val = Val
Next cell
OldSelectionCount = OldSelectionCount + 1
End Sub
The RevertState Sub will undo ONLY THE LAST ACTION! I am unable to allow more than the last entry to be undone. Code is as follows:
Private Sub RevertState()
Dim i As Integer, index As Integer
Dim prevItem As SaveRange
Dim address As String
OldWorkbook.Activate
OldSheet.Activate
Application.EnableEvents = False
address = OldSelection(OldSelectionCount - 1).Addr
OldSelectionCount = OldSelectionCount - 2
If OldSelectionCount <= 0 Then
ReDim OldSelection(0)
For i = 0 To InitialStateCount
If InitialState(i).Addr = address Then
prevItem.Val = InitialState(i).Val
index = i
End If
Next i
Range(InitialState(index).Addr).Formula = prevItem.Val
Else
ReDim Preserve OldSelection(OldSelectionCount)
For i = 0 To OldSelectionCount
If OldSelection(i).Addr = address Then
prevItem.Val = OldSelection(i).Val
index = i
End If
Next i
'OldSelectionCount = OldSelectionCount + 1
Range(OldSelection(index).Addr).Formula = prevItem.Val
End If
OldSelectionCount = OldSelectionCount + 1
Application.EnableEvents = True
End Sub
Does anyone know of a way to allow multiple undo's to be done?
Any help to solve this issue would be greatly appreciated!

Answer 1

After researching the Undo function on MSDN here, I found that the Application.Undo function only undoes the last action taken by the user. Instead of trying to get Microsoft's undo functionality to work, I have added my own undo and redo buttons which function the same as Microsoft's buttons. I have added two class modules: ActionState (holds the properties for workbook, worksheet, address and value of a cell)
ActionStates (a collection ActionState objects along with functions for adding, removing, getting an item, clearing the collection, counting, and properties for the CurrentState, and InitialState of the worksheet).
The new process is as follows:
Get the initial state of all the cells in the worksheet and add these to the undo stack array (see GetInitialCellStates() method within UndoFuntionality module).
When an item is added to a cell, add the address and value to the array (see SaveState() method within UndoFunctionality module) and update the index of the current state to the most recently added value. Repeat this step with any additional values.
When this is done, it enables the undo button.
If the undo button is pressed, it will decrement the index of the current state and enable the redo button (see RevertState() function within UndoFunctionality module).
If the redo button is pressed it will increment the index of the current state (see ProgressState() function within UndoFunctionality module).
The code for the ActionState class is as follows:
Private asAddr As String
Private asVal As Variant
Private asWorkbook As Workbook
Private asWorksheet As Worksheet
Private Sub Class_Initalize()
Set asWorkbook = New Workbook
Set asWorksheet = New Worksheet
End Sub
'''''''''''''''''''
' Addr property
'''''''''''''''''''
Public Property Get Addr() As String
Addr = asAddr
End Property
Public Property Let Addr(Value As String)
asAddr = Value
End Property
'''''''''''''''''''
' Val property
'''''''''''''''''''
Public Property Get Val() As Variant
Val = asVal
End Property
Public Property Let Val(Value As Variant)
asVal = Value
End Property
'''''''''''''''''''
' Wkbook property
'''''''''''''''''''
Public Property Get Wkbook() As Workbook
Set Wkbook = asWorkbook
End Property
Public Property Let Wkbook(Value As Workbook)
Set asWorkbook = Value
End Property
'''''''''''''''''''
' WkSheet property
'''''''''''''''''''
Public Property Get Wksheet() As Worksheet
Set Wksheet = asWorksheet
End Property
Public Property Let Wksheet(Value As Worksheet)
Set asWorksheet = Value
End Property
The code for the ActionStates class is as follows:
Private asStates As Collection
Private currState As Integer
Private initState As Integer
Private Sub Class_Initialize()
Set asStates = New Collection
End Sub
Private Sub Class_Termitate()
Set asStates = Nothing
End Sub
''''''''''''''''''''''''''''
' InitialState property
''''''''''''''''''''''''''''
Public Property Get InitialState() As Integer
InitialState = initState
End Property
Public Property Let InitialState(Value As Integer)
initState = Value
End Property
''''''''''''''''''''''''''''
' CurrentState property
''''''''''''''''''''''''''''
Public Property Get CurrentState() As Integer
CurrentState = currState
End Property
Public Property Let CurrentState(Value As Integer)
currState = Value
End Property
''''''''''''''''''''''''''''
' Add method
''''''''''''''''''''''''''''
Public Function Add(Addr As String, Val As Variant) As clsActionState
Dim asNew As New clsActionState
With asNew
.Addr = Addr
.Val = Val
End With
asStates.Add asNew
End Function
''''''''''''''''''''''''''''
' Count method
''''''''''''''''''''''''''''
Public Property Get count() As Long
If TypeName(asStates) = "Nothing" Then
Set asStates = New Collection
End If
count = asStates.count
End Property
''''''''''''''''''''''''''''
' Item method
''''''''''''''''''''''''''''
Public Function Item(index As Integer) As clsActionState
Set Item = asStates.Item(index)
End Function
''''''''''''''''''''''''''''
' Remove method
''''''''''''''''''''''''''''
Public Function Remove(index As Integer)
If TypeName(asStates) = "Nothing" Then
Set asStates = New Collection
End If
asStates.Remove (index)
End Function
''''''''''''''''''''''''''''
' Clear method
''''''''''''''''''''''''''''
Public Sub Clear()
Dim x As Integer
For x = 1 To asStates.count
asStates.Remove (1)
Next x
End Sub
These two classes are used in a new module called UndoFunctionality as follows:
Option Explicit
Public ActionState As New clsActionState
Public ActionStates As New clsActionStates
Public undoChange As Boolean
Public Sub SaveState(count As Integer, Addr As String, Val As Variant)
Dim i As Integer
Dim cell As Range
If TypeName(Selection) <> "Range" Or Selection.count > 1 Then Exit Sub
With ActionState
.Wkbook = ActiveWorkbook
.Wksheet = ActiveSheet
End With
If ActionStates.CurrentState < ActionStates.count Then
For i = ActionStates.CurrentState + 1 To ActionStates.count
ActionStates.Remove (ActionStates.count)
Next i
End If
For Each cell In Selection
ActionState.Addr = Addr
ActionState.Val = Val
Next cell
ActionStates.Add ActionState.Addr, ActionState.Val
ActionStates.CurrentState = ActionStates.count
End Sub
Public Sub RevertState()
Dim i As Integer, index As Integer
Dim prevItem As New clsActionState
Dim Address As String
'undoChange = True
With ActionState
.Wkbook.Activate
.Wksheet.Activate
End With
Application.EnableEvents = False
Address = ActionStates.Item(ActionStates.CurrentState).Addr
ActionStates.CurrentState = ActionStates.CurrentState - 1
For i = 1 To ActionStates.CurrentState
If ActionStates.Item(i).Addr = Address Then
prevItem.Val = ActionStates.Item(i).Val
index = i
End If
Next i
Range(ActionStates.Item(index).Addr).Formula = prevItem.Val
Application.EnableEvents = True
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub ProgressState()
Dim i As Integer, index As Integer
Dim nextItem As New clsActionState
Dim Address As String
With ActionState
.Wkbook.Activate
.Wksheet.Activate
End With
Application.EnableEvents = False
ActionStates.CurrentState = ActionStates.CurrentState + 1
With nextItem
.Addr = ActionStates.Item(ActionStates.CurrentState).Addr
.Val = ActionStates.Item(ActionStates.CurrentState).Val
End With
Range(ActionStates.Item(ActionStates.CurrentState).Addr).Formula = nextItem.Val
Application.EnableEvents = True
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub GetInitialCellStates()
Dim i As Integer, j As Integer, count As Integer
Dim cellVal As String
Dim sampID As Range, cell As Range
Dim e1664 As Workbook
Dim rawData As Worksheet
Dim table As Range
Dim LastRow As Integer, LastCol As Integer
ThisWorkbook.Worksheets("Raw_Data").Activate
If ActionStates.count > 0 Then
ActionStates.Clear
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
LastCol = Worksheets("Raw_Data").UsedRange.Columns.count
Set e1664 = ThisWorkbook
Set rawData = e1664.Sheets("Raw_Data")
Set sampID = rawData.Range("SAMPLEID").Offset(1)
Set table = rawData.Range(sampID, "R" & LastRow)
i = 0
j = 0
count = 0
For i = 0 To (LastRow - sampID.Row)
For j = 0 To LastCol
ActionState.Addr = sampID.Offset(i, j).Address
ActionState.Val = sampID.Offset(i, j).Value
ActionStates.Add ActionState.Addr, ActionState.Val
count = count + 1
Next j
Next i
ActionStates.InitialState = count
ActionStates.CurrentState = count
undoChange = False
UndoButtonAvailability
RedoButtonAvailability
End Sub
Public Sub UndoButtonAvailability()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If ActionStates.CurrentState <= ActionStates.InitialState Then
rawData.Buttons("UndoButton").Enabled = False
rawData.Buttons("UndoButton").Font.ColorIndex = 16
Else
rawData.Buttons("UndoButton").Enabled = True
rawData.Buttons("UndoButton").Font.ColorIndex = 1
End If
End Sub
Public Sub RedoButtonAvailability()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If ActionStates.CurrentState < ActionStates.count Then
rawData.Buttons("RedoButton").Enabled = True
rawData.Buttons("RedoButton").Font.ColorIndex = 1
Else
rawData.Buttons("RedoButton").Enabled = False
rawData.Buttons("RedoButton").Font.ColorIndex = 16
End If
End Sub
Sub UndoButton_Click()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If rawData.Buttons("UndoButton").Enabled Then
RevertState
End If
End Sub
Sub RedoButton_Click()
Dim rawData As Worksheet
Set rawData = ThisWorkbook.Sheets("Raw_Data")
If rawData.Buttons("RedoButton").Enabled Then
ProgressState
End If
End Sub
The GetInitialStates method is used in the workbook_open event as follows:
UndoFunctionality.GetInitialCellStates
And the Worksheet_Change event within the worksheet is as follows:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, InWtRange As Boolean
Dim y As Integer, x As Integer, count As Integer
Dim LastRow As Integer
'This saves the changed values of the cells
Call SaveState(ActionStates.CurrentState, Target.Cells.Address, Target.Cells.Value)
try:
y = Me.Range("SampleID").Row
If Target.Column > 5 And Target.Column < 8 Then
If Range("A" & Target.Row).Value = Range("A" & Target.Row + 1).Value Then
If Range("A" & Target.Row + 1).Value <> "" Then
Range(Target.Address).Offset(1).Value = Range(Target.Address).Value
End If
End If
Else
'If initial pan weight add start date
If Target.Column = 8 Then
If Target.Cells.Text <> "" Then
If Not IsNumeric(Target.Cells.Value) Then
GoTo Finally
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = Format(Now(), "MM/DD/YY HH:NN:SS")
Application.EnableEvents = True
End If
Else
Application.EnableEvents = False
Range("StartDate").Offset(Target.Cells.Row - y).Value = ""
Application.EnableEvents = True
End If
End If
End If
LastRow = Worksheets("Raw_Data").Range("A65536").End(xlUp).Row
For Each cell In Target.Cells
If cell.Value <> "" Then
If Not IsNumeric(cell.Value) Then GoTo Finally
Select Case cell.Column
Case 9, 11, 13
Application.EnableEvents = False
If CalcHEM(cell.Row - y, cell.Column) Then
End If
Application.EnableEvents = True
Case Else
'Do nothing yet
End Select
End If
Next
UndoFunctionality.UndoButtonAvailability
UndoFunctionality.RedoButtonAvailability
Finally:
If Application.EnableEvents = False Then Application.EnableEvents = True
Exit Sub
Catch:
MsgBox "An error has occurred in the code execution." & vbNewLine _
& "The message text of the error is: " & Error(Err), vbInformation, "TSSCalcs.AddQC"
Resume Finally
End Sub
The only thing left is to add two buttons to the worksheet and assign the macro used to the UndoButton_Click() and RedoButton_Click() events which will run the RevertState() and ProgressState() methods.

Answer 2

I found a little trick using Application.OnTime. So it is possible to use Undo repeatedly.
The Repeat button is not the Redo button. You can find it in the Edit menu or put it on your ribbon.
I am using Excel 2003.
Here is a working sample. Put the code inside ThisWorkbook module.
Dim Undos As New Collection
Sub Change()
' push previous cell values to the end of your undo array
Undos.Add ActiveCell.Value
' change the cell values as you wish
ActiveCell.Value = "(" + ActiveCell.Value + ")"
PlanUndo
PlanRepeat
End Sub
Sub Undo()
' make sure the undo array is not empty
If (Undos.Count > 0) Then
' pop previous cell values from the end of your undo array
Dim Value
Value = Undos.Item(Undos.Count)
Undos.Remove Undos.Count
' revert the cell values
ActiveCell.Value = Value
End If
If (Undos.Count > 0) Then
PlanUndo
End If
PlanRepeat
End Sub
Function PlanUndo()
Application.OnTime Now, "ThisWorkbook.SetUndo"
End Function
Sub SetUndo()
Application.OnUndo "Undo last change", "ThisWorkbook.Undo"
End Sub
Function PlanRepeat()
Application.OnTime Now, "ThisWorkbook.SetRepeat"
End Function
Sub SetRepeat()
Application.OnRepeat "Repeat last change", "ThisWorkbook.Change"
End Sub