The Undo for Excel VBA

VBA Macros in Excel clear the Undo stack. The stack is not easily accessible. The following link provides a Macro undo routine:

 

http://j-walk.com/ss/excel/tips/tip23.htm

 

This might be useful, but what about undoing previous actions when your VB "messes up the undo stack". The following code, which is loosely based on the link above - gives you a solution for that. It supports undo and redo, but has the following limitations:

 

1) You cannot undo formatting changes or cell-corner actions (double-click or drag).

2) It will only stacks a maximum of 1000 rows in a single change to avoid memory overflows.

3) To invoke a second undo action, you must at least change the cell selection.

 

I give you no warranty - use at own risk, but please give me and the original author credit for our work:

###################################################################################

Option Explicit
' Created by Gabriel Marcan (C) 2007

' I give you no warranty - use at own risk, but please give me and the original author credit for our work:

' Loosely based on http://j-walk.com/ss/excel/tips/tip23.htm
Public doList(10) As SavedRange
Public tempDo As SavedRange
Private isDo As Boolean
Public did As Boolean
Public bIndex As Integer
Public Const bLimit = 30
Public Type SavedRange
        Val As Variant
        isDo As Boolean
        RngName As String
        WsName As String
        WbName As String
End Type
Private Function ArraysEqual(a As Variant, b As Variant)
    On Error GoTo ReturnFalse
    Dim i As Integer
    Dim j As Integer
    If IsArray(a) And IsArray(b) Then
        For i = 1 To UBound(a, 1)
            For j = 1 To UBound(b, 2)
                If Not CStr(a(i, j)) = CStr(b(i, j)) Then GoTo ReturnFalse
            Next j
        Next i
        ArraysEqual = True
    Else
        If a = b Then ArraysEqual = True
    End If
    Exit Function
ReturnFalse:
    ArraysEqual = False
End Function
Sub MyDo()
     
    On Error GoTo NoDo
        If isDo Then MoveIndex
        If IsEmpty(doList(bIndex).Val) Then doList(bIndex).Val = ""
        did = True
        Dim rg As Range
        If doList(bIndex).WbName = "" Then Err.Raise 51, , "No History available"
        Set rg = Workbooks(doList(bIndex).WbName). _
                        Worksheets(doList(bIndex).WsName). _
                        Range(doList(bIndex).RngName)
        rg.Select
        If doList(bIndex).isDo = isDo Then Err.Raise 51, , "No History available"
        If ArraysEqual(rg.Value, doList(bIndex).Val) Then Err.Raise 51, , _
            "Cell corner actions (drag or double click) are not supported"
        rg.Formula = doList(bIndex).Val ' IsArray ubound
        If Not isDo Then MoveIndex
        did = False
       
        GoTo TheEnd
NoDo:
    Dim reun As String
    If isDo Then reun = "Re" Else reun = "Un"
   
    did = False
    If isDo Then
        isDo = False
        MoveIndex
    End If
   
    MsgBox "Cannot " + reun + "do. " + "More Details: " + Err.Description, , "Message"
    did = False
TheEnd:
        setupDo
End Sub
Public Sub Undo_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not did Then
        isDo = True
        tempDo.isDo = True
    End If
    If Not did Then MoveIndex
   
    doList(bIndex) = tempDo
   
    setupDo
End Sub
Public Sub MoveIndex()
    bIndex = bIndex + ((2 * Abs(CInt(isDo))) - 1)
    If (bIndex > bLimit) Then bIndex = 0
    If bIndex < 0 Then bIndex = bLimit
End Sub
Public Sub Undo_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
    On Error GoTo SkipSub
    tempDo.WbName = Sh.Parent.Name
    tempDo.WsName = Sh.Name
    tempDo.RngName = Target.Address
    tempDo.isDo = isDo
    If (Target.Rows.Count > 1000) Then
        tempDo.RngName = _
             CStr(Target.Cells(1, 1).Address) + ":" + _
             CStr(Target.Cells.SpecialCells(xlCellTypeLastCell).Address)
    End If
    tempDo.Val = Range(tempDo.RngName).Formula
SkipSub:
    setupDo
End Sub
Private Sub setupDo()
Application.OnUndo "Undo Last action", "MyUndo"
Application.OnRepeat "Redo Last action", "MyRedo"
End Sub
Sub MyUndo()
isDo = False
MyDo
End Sub
Sub MyRedo()
isDo = True
MyDo
End Sub

##############################################################################

 

Feel free to comment, suggests improvements or send me your feedback on this code.