代码之家 › 专栏 › 技术社区 › user9520359

事件后启动图纸保护时,如何使已编辑的空单元格保持解锁状态

locking excel vba

user9520359 · 技术社区 · 6 年前

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

当输入数据,然后在不受保护的工作表中删除数据时,代码将无法允许将数据出租到删除数据的相同单元格中,是否有好的方法来启用此功能?
我尝试了一些与Target相关的选项。单元格,活动表。UsedRange、ActiveSHeet。Onetry和应用程序。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

1 回复 | 直到 6 年前

rellampec 6 年前

尝试以下操作:

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

有些更改是为了可读性,有些是为了适应您所寻求的功能,有些是为了避免循环。希望这有助于。。。如有任何问题,请发表评论并添加解释。

粘贴区域时,它应该可以工作(空单元格仍然可以编辑)