撤消功能对删除功能不起作用

Question

我一直在尝试为我的删除功能实现撤消代码，以避免用户在工作表上意外删除。

我的撤消代码适用于我的更新功能，但不适用于我的删除功能。

代码会运行，但是当我在保存更改消息框中按no按钮时，删除的数据大部分时间都不会返回。

＆＃34;撤消＆＃34;当我单击oselect以确定是否要保存更改时，函数基本上是返回no范围（我使用用户输入选项选择的范围）的代码。

这是我的代码：

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

这里有什么问题？

Answer 1

删除第一个选择（oselect）的上半部分时似乎出错，因此范围无效。我的解决方案使用另一个工作表（shtUndo）复制“撤消”范围，最后可以将其复制回来。

首先，您应该为撤消数据创建（或重命名）工作表。我调用了表单 UndoSheet ，并为其命名shtUndo，以便可以将其作为变量访问。您可以通过转到VBA编辑器为其命名，然后选择工作表，在这里您可以编辑(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)），您可以将其定义为子中的变量：

Dim shtUndo As Worksheet
set sht=Sheets("UndoSheet")

如果您希望用户不要看到 UndoSheet ，您可以隐藏它，您也可以通过VBA编辑器访问工作表属性。

更新：为了保留同时删除的链接单元格的值，我使用PasteSpecial xlPasteValuesAndNumberFormats函数。

注意1 ：例如，Sheet1在A1上的=A3引用另一个单元格：A3，然后删除A1 }，#REF!的值将是错误：xlPasteValues。

注意2 ：如果原始单元格中有任何公式，则按值（function showModal(templateUrl){ return $modal.open({ templateUrl: templateUrl, controller: ModalInstanceCtrl, resolve: { items: function () { return $scope.items; } }; } } ）复制将仅复制结果值，而不复制公式。

Answer 2

尝试以下操作，而不是使用一些额外的变量来获取有关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