撤消function不起作用
我一直在试图实现我的删除函数的撤消代码，以避免用户在工作表上的任何意外删除。
我的撤消代码适用于我的更新function，但不适用于我的删除function。
代码运行但删除的数据不会返回大部分时间，当我在保存更改消息框中按nobutton。
“撤销”function基本上是当我点击“ no来select是否要保存更改时，返回select范围的代码（我select用户input选项的范围）。
这是我的代码：
Sub DatabaseWannabe() Dim oselect As Range, vUndo As Variant On Error Resume Next Set oselect = Application.InputBox("Range?", , Selection.Address, , , , , 8) On Error GoTo 0 If TypeName(oselect) <> "Range" Then Exit Sub End If oselect.Select vUndo = oselect Dim rng As Range, rngError As Range, delRange As Range Dim i As Long, j As Long, k As Long Dim wks As Worksheet On Error Resume Next Set rng = Application.InputBox("Select cells to be deleted", Type:=8) On Error GoTo 0 If rng Is Nothing Then Exit Sub Else rng.Delete Shift:=xlToLeft For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets Set wks = ThisWorkbook.Worksheets(k) With wks For i = 1 To 26 '<~~ Loop through columns A to G '~~> Check if column has any errors On Error Resume Next Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors) On Error GoTo 0 If Not rngError Is Nothing Then For j = 1 To 200 '<~~ Loop through rows 1 to 100 If .Cells(j, i).Text = "#REF!" Then '~~> Store the range to be deleted If delRange Is Nothing Then Set delRange = .Cells(j, i) Else Set delRange = Union(delRange, .Cells(j, i)) End If End If Next j End If Next i End With If Not delRange Is Nothing Then delRange.Delete Set delRange = Nothing Next k If MsgBox("Save Changes?", vbYesNo) = vbNo Then oselect = vUndo End If '~~> Delete the range in one go End Sub
这里有什么问题？
当您删除第一个select（ oselect ）的上半部分时，似乎出错，因此范围无效。 我的解决scheme使用另一个工作表（ shtUndo ），它将“撤消”范围复制到最后，然后可以将其复制回来。
首先，您应该为撤消数据创build（或重命名）工作表。 我打电话给工作表UndoSheet ，我给它一个名字shtUndo这样它就可以作为一个variables来访问。 你可以通过VBA编辑器给它一个名字，然后select表单，在这里你可以编辑(Name)属性。
更新后的代码如下：
Option Explicit 'A good habit, to track errors beforehand. Sub DatabaseWannabe() 'define oselect, for undo Dim oselect As Range Dim oselectRow As Integer, oselectCol As Integer, _ oselectRowCount As Integer, oselectColCount As Integer Dim oselectSht As Worksheet On Error Resume Next 'get oselect Set oselect = Application.InputBox("Range?", , Selection.Address, , , , , Type:=8) 'check if selection set If oselect Is Nothing Or oselect.Cells.Count = 0 Then MsgBox "No selection set." Exit Sub End If 'define location and size of selection Set oselectSht = oselect.Parent oselectRow = oselect.Row oselectCol = oselect.Column oselectRowCount = oselect.Cells.Rows.Count oselectColCount = oselect.Columns.Count On Error GoTo 0 'now copy data to (hidden) sheet oselect.Copy 'to keep the values of linked cells, copy by value 'Note: if you want to keep formulas, then remove the parameter `xlPasteValuesAndNumberFormats` (although then deleted reference cells will not be visible anymore). shtUndo.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats 'copy the formatting shtUndo.Range("A1").PasteSpecial xlPasteFormats '--- your algorithm --- Dim rng As Range, rngError As Range, delRange As Range Dim i As Long, j As Long, k As Long Dim wks As Worksheet On Error Resume Next Set rng = Application.InputBox("Select cells To be deleted", Type:=8) On Error GoTo 0 If rng Is Nothing Then Exit Sub Else rng.Delete Shift:=xlToLeft For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets Set wks = ThisWorkbook.Worksheets(k) With wks For i = 1 To 26 '<~~ Loop trough columns A to G '~~> Check if that column has any errors On Error Resume Next Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors) On Error GoTo 0 If Not rngError Is Nothing Then For j = 1 To 200 '<~~ Loop Through rows 1 to 100 If .Cells(j, i).Text = "#REF!" Then '~~> Store The range to be deleted If delRange Is Nothing Then Set delRange = .Cells(j, i) Else Set delRange = Union(delRange, .Cells(j, i)) End If End If Next j End If Next i End With If Not delRange Is Nothing Then delRange.Delete Set delRange = Nothing Next k If MsgBox("Save Changes?", vbYesNo) = vbNo Then 'copy data from undo sheet shtUndo.Range("A1").Resize(oselectRowCount, oselectColCount).Copy oselectSht.Cells(oselectRow, oselectCol).PasteSpecial End If shtUndo.Cells.Clear End Sub
如果你不想使用图纸名称（即设置属性(Name) ），你可以在sub中将其定义为一个variables：
Dim shtUndo As Worksheet set sht=Sheets("UndoSheet")
如果您希望用户不要看到UndoSheet ，您可以隐藏它，您也可以在表单属性中进行隐藏，可以通过VBA编辑器访问。
更新 ：保持同时删除的链接单元格的值我使用PasteSpecial xlPasteValuesAndNumberFormats函数。
注意1 ：例如，在A1 Sheet1上放置对另一个单元格的引用： =A3 ，然后删除A3 ，则A1的值将出现错误： #REF! 。
注2 ：如果在原始单元格中有任何公式，则通过值（ xlPasteValues ）进行复制将仅复制结果值，而不是公式。
请尝试以下代码，使用一些额外的variables来获取有关oselect范围和它所在工作表的详细信息。如果撤消，则代码将返回到此范围内的第一个单元格，调整范围以适合vUndo数组，然后将数组写回范围：
Sub DatabaseWannabe() Dim oselect As Range, vUndo As Variant, vAdd As String, vSh As Worksheet On Error Resume Next Set oselect = Application.InputBox("Range?", , Selection.Address, , , , , 8) On Error GoTo 0 If TypeName(oselect) <> "Range" Then Exit Sub End If vUndo = oselect.Value vAdd = oselect.Cells(1).Address Set vSh = oselect.Parent Dim rng As Range, rngError As Range, delRange As Range Dim i As Long, j As Long, k As Long Dim wks As Worksheet On Error Resume Next Set rng = Application.InputBox("Select cells to be deleted", Type:=8) On Error GoTo 0 If rng Is Nothing Then Exit Sub Else rng.Delete Shift:=xlToLeft For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets Set wks = ThisWorkbook.Worksheets(k) With wks For i = 1 To 26 '<~~ Loop through columns A to G '~~> Check if column has any errors On Error Resume Next Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors) On Error GoTo 0 If Not rngError Is Nothing Then For j = 1 To 200 '<~~ Loop through rows 1 to 100 If .Cells(j, i).Text = "#REF!" Then '~~> Store the range to be deleted If delRange Is Nothing Then Set delRange = .Cells(j, i) Else Set delRange = Union(delRange, .Cells(j, i)) End If End If Next j End If Next i End With If Not delRange Is Nothing Then delRange.Delete Set delRange = Nothing Next k If MsgBox("Save Changes?", vbYesNo) = vbNo Then vSh.Range(vAdd).Resize(UBound(vUndo, 1) - LBound(vUndo, 1) + 1, _ UBound(vUndo, 2) - LBound(vUndo, 2) + 1).Value = vUndo End If '~~> Delete the range in one go End Sub