vba 运行宏 excel 后清除“撤消”历史按钮
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/7798575/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
"Undo" history button clear after run macro excel
提问by eicruzado
I have a macro that fires on the "Worksheet_SelectionChange"event. The macro validate data of one column, it changes the background color of the cell if its wrong.
我有一个在“Worksheet_SelectionChange”事件上触发的宏。宏验证一列的数据，如果错误则更改单元格的背景颜色。
The problem is after run the macro, it clears the history of changes (Ctrl Z) of all the document, even the history changes of other cells that I didnt validate.
问题是运行宏后，它清除了所有文档的更改历史记录（Ctrl Z），甚至是我没有验证的其他单元格的历史更改。
How can I solve this problem?
我怎么解决这个问题？
Thanks.
谢谢。
采纳答案by aevanko
As the others have stated, there is not way to stop a worksheet-changing macro from clearing the undo stack.
正如其他人所说，没有办法阻止更改工作表的宏清除撤消堆栈。
As another side-effect, you can't undo the macro either without writing your own Undo routine, which can be a huge hassle.
作为另一个副作用，如果不编写自己的撤消例程，您也无法撤消宏，这可能会非常麻烦。
Here's to hoping MS changes this in the future.
这是希望 MS 在未来改变这一点。
回答by Cesar
I had this issue and wound up having to create custom undo functionality. It works very similar to the native undo except for the following. I am sure they can be handled with a little more attention.
我遇到了这个问题，最终不得不创建自定义撤消功能。除了以下内容外，它的工作方式与本机撤消非常相似。我相信他们可以多加注意处理。
1) Custom undo does not undo formatting. Only text.
1) 自定义撤消不会撤消格式。只有文字。
2) Custom undo goes all the way to end of the custom stack. Once this happens the stack is cleared and it does not toggle between the last two items like in the native undo functionality.
2）自定义撤消一直到自定义堆栈的末尾。一旦发生这种情况，堆栈将被清除，并且不会像在本机撤消功能中那样在最后两项之间切换。
2.1) Does not have REDO functionality.
2.1) 没有重做功能。
Download a working copy of this code.
Module UndoModule
模块 UndoModule
Public UndoStack() As UndoStackEntry
Private Const UndoMaxEntries = 50
Public Sub SaveUndo(ByVal newUndo As UndoStackEntry)
'Save the last undo object
If Not newUndo Is Nothing Then
Call AddUndo(newUndo)
End If
End Sub
Public Sub Undo()
'Appy last undo from the stack and remove it from the array
Dim previousEdit As UndoStackEntry
Set previousEdit = GetLastUndo()
If Not previousEdit Is Nothing Then
Dim previousEventState As Boolean: previousEventState = Application.EnableEvents
Application.EnableEvents = False
Range(previousEdit.Address).Select
Range(previousEdit.Address).Value = previousEdit.Value
Application.EnableEvents = previousEventState
Call RemoveLastUndo
End If
End Sub
Private Function AddUndo(newUndo As UndoStackEntry) As Integer
If UndoMaxEntries < GetCount() Then
Call RemoveFirstUndo
End If
On Error GoTo ErrorHandler
ReDim Preserve UndoStack(UBound(UndoStack) + 1)
Set UndoStack(UBound(UndoStack)) = newUndo
AddUndo = UBound(UndoStack)
ExitFunction:
Exit Function
ErrorHandler:
ReDim UndoStack(0)
Resume Next
End Function
Private Function GetLastUndo() As UndoStackEntry
Dim undoCount As Integer: undoCount = GetCount()
If undoCount > 0 Then
Set GetLastUndo = UndoStack(undoCount - 1)
End If
End Function
Private Function RemoveFirstUndo() As Boolean
On Error GoTo ExitFunction
RemoveFirstUndo = False
Dim i As Integer
For i = 1 To UBound(UndoStack)
Set UndoStack(i - 1) = UndoStack(i)
Next i
ReDim Preserve UndoStack(UBound(UndoStack) - 1)
RemoveFirstUndo = True
ExitFunction:
Exit Function
End Function
Private Function RemoveLastUndo() As Boolean
RemoveLastUndo = False
Dim undoCount As Integer: undoCount = GetCount()
If undoCount > 1 Then
ReDim Preserve UndoStack(undoCount - 2)
RemoveLastUndo = True
ElseIf undoCount = 1 Then
Erase UndoStack
RemoveLastUndo = True
End If
End Function
Private Function GetCount() As Long
GetCount = 0
On Error Resume Next
GetCount = UBound(UndoStack) + 1
End Function
Class Module UndoStackEntry
类模块 UndoStackEntry
Public Address As String
Public Value As Variant
Also needed to attach to the following events on the WORKBOOK Excel object.
还需要附加到 WORKBOOK Excel 对象上的以下事件。
Public Sub WorkbookUndo()
On Error GoTo ErrHandler
ThisWorkbook.ActiveSheet.PageUndo
ErrExit:
Exit Sub
ErrHandler:
On Error GoTo ErrExit
Application.Undo
Resume ErrExit
End Sub
Finally each sheet where you require undo to work should have the following code attached to its events.
最后，您需要撤消才能工作的每个工作表都应将以下代码附加到其事件中。
Dim tmpUndo As UndoStackEntry
Dim pageUndoStack() As UndoStackEntry
Private Sub OnSelectionUndoCapture(ByVal Target As Range)
Set tmpUndo = New UndoStackEntry
tmpUndo.Address = Target.Address
tmpUndo.Value = Target.Value
UndoModule.UndoStack = pageUndoStack
End Sub
Private Sub OnChangeUndoCapture(ByVal Target As Range)
Application.OnKey "^{z}", "ThisWorkbook.WorkbookUndo"
Application.OnUndo "Undo Procedure", "ThisWorkbook.WorkbookUndo"
If Not Application.Intersect(Target, Range(tmpUndo.Address)) Is Nothing Then
If Target.Value <> tmpUndo.Value Or Empty = Target.Value Then
UndoModule.UndoStack = pageUndoStack
Call UndoModule.SaveUndo(tmpUndo)
pageUndoStack = UndoModule.UndoStack
End If
End If
End Sub
Public Sub PageUndo()
UndoModule.UndoStack = pageUndoStack
Call UndoModule.Undo
pageUndoStack = UndoModule.UndoStack
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Stash away the value of the first cell in the selected range
On Error Resume Next
Call OnSelectionUndoCapture(Target)
oldValue = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If tmpUndo.Value <> Target.Value Then
'Do some stuff
End If
Call OnChangeUndoCapture(Target)
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
