Question

我有一个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子中完成的。这里的重要部分是调用SaveState（OldSelectionCount，Target.Cells.address，Target.Cells.Value）和 Application.OnUndo＆＃34;撤消上一个操作＆＃34;，＆＃34; GI.OR.E1664.20150915_DRAFT.xlt！Sheet1.RevertState＆＃34; 件，如下面的数字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

有没有人知道允许多个撤消操作的方法？

非常感谢任何有助于解决此问题的帮助！

Answer 1

在研究MSDN here上的撤销功能后，我发现Application.Undo功能只撤消用户采取的最后一个动作。我没有试图让微软的撤销功能起作用，而是添加了我自己的撤销和重做按钮，其功能与微软的按钮相同。我添加了两个类模块：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

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

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

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

Answer 2

我发现了一个使用Application.OnTime的小技巧。因此可以反复使用撤消。 “重复”按钮不是“重做”按钮。您可以在“编辑”菜单中找到它或将其放在功能区上。我正在使用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

如何在excel vba中允许多个连续的undos？

2 个答案: