我有一个宏会在"Worksheet_SelectionChange" 事件上触发。该宏验证一列数据,如果数据不正确,则更改单元格的背景颜色。
问题在于运行宏后,它会清除文档中所有更改的历史记录(Ctrl Z),即使是我没有验证的其他单元格的历史更改也会被清除。
如何解决这个问题?
谢谢。
问题在于运行宏后,它会清除文档中所有更改的历史记录(Ctrl Z),即使是我没有验证的其他单元格的历史更改也会被清除。
如何解决这个问题?
谢谢。
我曾经遇到过这个问题,最终不得不创建自定义撤销功能。它的工作方式与原生的撤销类似,但有以下几点不同。我相信只需要多加注意就可以解决。
1) 自定义撤销不会撤销格式,只能撤销文本。
2) 自定义撤销会一直到达自定义堆栈的末尾。一旦发生这种情况,堆栈就会被清除,不像原生撤销功能那样在最后两个项目之间切换。
2.1) 没有REDO功能。
模块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
类模块UndoStackEntry
Public Address As String
Public Value As Variant
还需要附加到 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
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
正如其他人所说,无法阻止更改工作表的宏清除撤消堆栈。
另一个副作用是,如果没有编写自己的撤消程序,也无法撤消宏,这可能会非常麻烦。
希望微软未来能够改变这一点。