仿Excel的撤销功能

fanjy

发布于 2024-05-13 08:08:18

25200

代码可运行

文章被收录于专栏：完美Excel完美Excel

运行总次数：0

代码可运行

标签：VBA，工作表事件

这是在www.vbaexpress.com中看到的一个示例，实现了自己以前想做而未做的事情。

也就是，模仿Excel的撤销功能，特别是当VBA代码对工作表进行操作后，使用Excel原始的撤销功能是无法恢复的，但可以使用VBA代码来实现，似乎就像Excel的撤销功能一样。

主要思路是使用一个工作表，来记录对工作表所做的修改，如果要撤销这些修改，就从这个工作表取出原来的值来恢复。注意，本文的示例只针对特定区域，且只能撤销两次。

在ThisWorkbook模块中，输入下面的代码：

Private Sub Workbook_Open()
 Dim endRow As Long
 
 With Sheets("UNDO")
   endRow = .Cells(Rows.Count, 1).End(xlUp).Row
   If endRow > 1 Then
     .Range("A2:D" & endRow).ClearContents
   End If
 End With
End Sub

在操作的工作表相应的代码模块中输入下面的代码：

Dim i As Long
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim rngToProcess As Range
 Dim sNewValue
 Dim sOldValue
 Dim rCell As Range
 Dim nr As Long
 
 Set rngToProcess = Intersect(Target, Range("C5:C14")) '设置可编辑的单元格区域
 If Not rngToProcess Is Nothing Then
   Application.EnableEvents = False
   sNewValue = Target.Value
   sOldValue = Target.Offset(, 1).Value
   Application.UNDO ' 撤销最后一次输入
   Target.Offset(, 1).Value = Target.Value
  ' 将之前的值放置到目标单元格右侧的单元格
   i = i + 1 ' 增加实例, 用于UNDO过程
   For Each rCell In rngToProcess ' 遍历目标区域中的单元格
     With Sheets("UNDO")
       nr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
       .Range("A" & nr) = i
       .Range("B" & nr) = rCell.Address
       .Range("C" & nr) = rCell.Offset(, 1).Value
       .Range("D" & nr) = sOldValue
     End With
   Next rCell
   Target.Value = sNewValue
   Application.EnableEvents = True
 End If
End Sub

插入一个标准模块，输入下面的代码：

Sub UNDO()
 Dim wsU As Worksheet
 Dim ws1 As Worksheet
 Dim x As Long
 Dim wsUend As Long
 Dim inst As Long
 Dim rCell As Range
 
 Application.EnableEvents = False ' 关闭事件以便下面的代码不会触发Worksheet_Change事件
 Set wsU = Sheets("UNDO") ' 名为UNDO的隐藏工作表
 Set ws1 = Sheets("Sheet1") ' 要撤销操作的工作表
 wsUend = wsU.Cells(Rows.Count, 1).End(xlUp).Row ' 工作表UNDO的最后有数据的行
 On Error GoTo JumpOut ' 如果下一行的代码产生错误则跳转到过程底部的JumpOut处
 inst = wsU.Range("A" & wsUend).Value ' 添加到UNDO工作表中的最新实例
 On Error GoTo 0 ' 恢复错误处理
 
 For x = wsUend To 2 Step -1 ' 向前遍历UNDO工作表
   If wsU.Range("A" & x) = inst Then ' 检查UNDO工作表的当前行是否是最新实例
     Set rCell = ws1.Range(wsU.Range("B" & x)) ' 创建对ws1单元格区域的引用
     rCell.Value = wsU.Range("C" & x).Value ' 将之前的值写回ws1
     rCell.Offset(, 1) = wsU.Range("D" & x).Value ' 将之前的值写回ws1
     wsU.Range("A" & x & ":D" & x).ClearContents ' 清空UNDO工作表中的行, 这允许有更多的撤销
   Else
     Exit For ' 退出循环
   End If
 Next x
 Application.EnableEvents = True ' 恢复事件触发
 Exit Sub
JumpOut:
 Application.EnableEvents = True ' 恢复事件触发
 MsgBox "没有什么可以撤销", vbInformation, "UNDO"
End Sub