Question

我想在输入数据时锁定工作表中的单元格。此外，管理员可以在必须进行更改时取消保护工作表。但是使用此代码我有以下问题：

当输入数据然后不保护用于删除数据的表单时，代码无法允许将数据重新计入到删除数据的相同单元格中，是否有一个很好的方法来启用它？
我尝试了一些与Target.Cells，ActiveSheet.UsedRange，ActiveSHeet.OnEntry和Application.OnKey相关的选项，但似乎没有任何内容覆盖delete / baackspace事件。

任何帮助将不胜感激。这是当前的代码：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ToLock As String
Dim R As Range
Application.ScreenUpdating = False
ToLock = MsgBox("This input will now be locked.", vbOKCancel, "Confirm Change")

    ''If locking is accepted
    If ToLock <> vbOK Then
        Application.EnableEvents = False
        Target.ClearContents 
        Application.EnableEvents = True
    Exit Sub
    End If

''Once entry entered, sheet will be locked with this password
        ActiveSheet.Unprotect "quality"
'            For Each R In ActiveSheet.UsedRange
            For Each R In Target.Cells
            If R.Value <> "" Then
                Target.Locked = True
            End If
            Next R
        ActiveSheet.Protect Password:="quality", DrawingObjects:=True, Contents:=True, Scenarios:=True
        Application.ScreenUpdating = True
End Sub

Answer 1

试试这个：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rnCell As Range, rnEmpty As Range
 On Error Resume Next

 Set rnEmpty = emptyCells(Target)
 If Not (rnEmpty Is Nothing) Then
    If rnEmpty.Address = Target.Address Then Exit Sub
 End If

 Application.ScreenUpdating = False
 Application.EnableEvents = False

 On Error GoTo ChangeEnd
 If MsgBox("This input will now be locked.", vbOKCancel, "Confirm Change") = vbCancel Then
   Target.ClearContents
   GoTo ChangeEnd
 End If

 ActiveSheet.Unprotect "quality"
 Target.Locked = True
 Set rnEmpty = emptyCells(ActiveSheet.UsedRange)
 If Not (rnEmpty Is Nothing) Then rnEmpty.Locked = False

ChangeEnd:
 ActiveSheet.Protect Password:="quality", DrawingObjects:=True, Contents:=True, Scenarios:=True
 Application.EnableEvents = True
 Application.ScreenUpdating = True
End Sub

Private Function emptyCells(rnIn As Range) As Range
 On Error Resume Next
 If rnIn.Cells.Count = 1 Then
    If (rnIn.Value = vbNullString) And (rnIn.Formula = vbNullString) Then
        Set emptyCells = rnIn
    End If
 Else
    Set emptyCells = rnIn.SpecialCells(Type:=xlCellTypeBlanks)
 End If
End Function

为了便于阅读，引入了一些更改，其他一些更改适合您寻求的功能，其他更改则用于避免循环。希望有帮助...任何问题，请评论并添加说明。

粘贴范围时应该有效（空单元格仍可编辑）

在事件发生后启动表单保护时，如何将已编辑的空单元解锁

1 个答案: