如何在excel vba中允许多个连续撤消？答案

【问题标题】：How to allow multiple successive undos in excel vba?如何在excel vba中允许多个连续撤消？
【发布时间】：2015-12-14 15:55:23
【问题描述】：

我有一个 Excel 工作簿，需要允许用户撤消工作表中的多项更改。我在每个我能想到的论坛上都在网上搜索过，但一直没有找到答案。我意识到在运行宏时，excel 中的撤消问题存在问题，并且能够使用派生自 here 的代码来处理此问题。

这是我目前的流程：

创建全局变量以保存工作簿的初始状态和更改。代码如下：

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

通过构建一个包含 Workbook_Open 子中所有单元格的值的数组 (InitialState) 来获取工作簿的初始状态。代码如下：

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

在单元格中输入值时，将输入的值存储到另一个数组 (OldSelection) 中，该数组保存输入的值。这是在 Workbook_Change 子中完成的。这里的重要部分是 Call SaveState(OldSelectionCount, Target.Cells.address, Target.Cells.Value) 和 Application.OnUndo "Undo the last action", "GI.OR.E1664 .20150915_DRAFT.xlt!Sheet1.RevertState" 件，如下面的数字 4 和 5 所示。代码如下：

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

SaveState Sub 将保存添加到 OldSelection 数组中的任何已更改的值。代码如下：

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

RevertState Sub 只会撤消最后一个操作！我不能允许撤消最后一个条目。代码如下：

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

有谁知道允许多次撤消的方法吗？

任何解决此问题的帮助将不胜感激！

【问题讨论】：

过去曾研究过类似的问题（不是在 Excel 中），其想法是创建一种堆栈结构来保存一系列状态，而不是只保存一个状态。跨度>
您可能会发现这篇文章和示例对您的项目很有趣。创建撤消处理程序以撤消 Excel VBAjkp-ads.com/Articles/UndoWithVBA00.asp> 所做的更改和撤消处理程序示例 jkp-ads.com/downloadscript.asp?filename=UndoHandler.zip>
您发给我的两个链接都失效了，但是包含您所指信息的链接应该是here。虽然这是很好的信息，但代码需要的调试比它的价值要多。真正的问题在于 onUndo 方法。如果可能的话，我想使用微软的，但我自己写可能更容易。如果我找到解决方案，我会发布它。
您解决了吗？
请参阅下面关于我如何解决此问题的答案。

标签： excel undo vba

【解决方案1】：

我发现了一个使用 Application.OnTime 的小技巧。因此可以重复使用 Undo。重复按钮不是重做按钮。您可以在“编辑”菜单中找到它或将其放在功能区上。我正在使用 Excel 2003。这是一个工作示例。将代码放在 ThisWorkbook 模块中。

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

【讨论】：

【解决方案2】：

研究了MSDNhere上的Undo功能，发现Application.Undo功能只撤消用户最后一次执行的操作。我没有尝试让 Microsoft 的撤消功能发挥作用，而是添加了自己的撤消和重做按钮，它们的功能与 Microsoft 的按钮相同。我添加了两个类模块：ActionState（保存工作簿、工作表、地址和单元格值的属性） ActionStates（ActionState 对象集合以及用于添加、删除、获取项目、清除集合、计数和 CurrentState 的属性以及工作表的 InitialState 的函数）。新流程如下：

获取工作表中所有单元格的初始状态并将它们添加到撤消堆栈数组（请参阅 UndoFuntionality 模块中的 GetInitialCellStates() 方法）。
将项目添加到单元格时，将地址和值添加到数组中（请参阅 UndoFunctionality 模块中的 SaveState() 方法）并将当前状态的索引更新为最近添加的值。对任何其他值重复此步骤。
完成后，它会启用撤消按钮。
如果撤消按钮被按下，它将减少当前状态的索引并启用重做按钮（参见 UndoFunctionality 模块中的 RevertState() 函数）。
如果按下重做按钮，它将增加当前状态的索引（请参阅 UndoFunctionality 模块中的 ProgressState() 函数）。

ActionState类的代码如下：

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

ActionStates 类的代码如下：

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

这两个类在一个名为 UndoFunctionality 的新模块中使用如下：

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

在workbook_open事件中使用GetInitialStates方法如下：

UndoFunctionality.GetInitialCellStates

而工作表内的Worksheet_Change事件如下：

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

剩下的唯一事情是在工作表中添加两个按钮，并将用于运行 RevertState() 和 ProgressState() 方法的 UndoButton_Click() 和 RedoButton_Click() 事件分配给宏。

【讨论】：

能否请您详细说明Raw_Data 表、SAMPLEID 和表？
另外，缺少CalcHEM 函数。