VBA 在工作表給定范圍內保護和解除保護

Question

我已經應用這個宏來保護和取消保護工作表中給定范圍的單元格這是我在這個宏中面臨的問題當我運行這個宏時這個宏在給定范圍的單元格 A1 到 D20 中保護和當我再次運行時這個宏在給定范圍內取消保護它不是取消保護

Sub lockcells()
 Dim Rng
 Dim MyCell
 Set Rng = Range("A1:D20")
 For Each MyCell In Rng
 If MyCell.Value = "" Then
 Else: ActiveSheet.UnProtect Password:="123"
 MyCell.Locked = True
 MyCell.FormulaHidden = False
 ActiveSheet.Protect Password:="123", UserInterFaceOnly:=True
 End If
 Next
End Sub

我想用單個宏保護和取消保護

Answer 1

一些小的調整使其“保護/取消保護”。 我假設您只想保護/鎖定不為空的單元格。

Option Explicit

Sub lockcells()
Dim Rng As Range
Dim MyCell As Object

Set Rng = Range("A1:D20") 'Set range to lock cells

If ActiveSheet.ProtectContents = True Then 'Check if sheet is protected
    ActiveSheet.Unprotect Password:="123" 'Password to unprotect
Else
For Each MyCell In Rng
    If MyCell.Value <> "" Then 'If cell is empty, if not empty lock the cell
        MyCell.Locked = True 'Lock cell
        MyCell.FormulaHidden = False 'Don't hide formulas
    End If
Next MyCell
ActiveSheet.Protect Password:="123", UserInterFaceOnly:=True 'Protect Sheet
End If
End Sub

---

如果您希望除范圍之外的所有單元格都是可編輯的，您可以添加以下代碼：

'Else
    ActiveSheet.Cells.Locked = False
    ActiveSheet.Cells.FormulaHidden = False
    'For Each MyCell In Rng

這將使只有Range("A1:D20")受密碼保護。 所有其他單元格都可以自由編輯。

Answer 2

解鎖細胞並隱藏它們的公式

• 您應該考慮使用If Not IsEmpty(sCell)額外鎖定包含計算為""的公式（將被隱藏）的單元格。 這對我來說更有意義。 想想看。

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Locks the non-blank cells in a range and hides their formulas.
' Remarks:      First it unlocks all cells and unhides their formulas.
'               Then, if previously all cells were unlocked, it locks
'               the non-blank cells and hides their formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ToggleLockCells()
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = Sheet1
    Dim srg As Range: Set srg = ws.Range("A1:D20")
    
    Dim trg As Range
    Dim sCell As Range
    
    ' Test if no cell is locked.
    If Not IsAnyCellLocked(srg) Then ' no locked cells
        For Each sCell In srg.Cells
            ' 'Blank' ...
            If Len(CStr(sCell.Value)) > 0 Then
            ' ... or 'Empty' to also lock cells with formulas evaluating to ""
            'If Not IsEmpty(sCell) Then '
                Set trg = GetCombinedRange(trg, sCell)
            End If
        Next
    'Else ' at least one cell is locked
    End If
    
    Application.ScreenUpdating = False
    If ws.ProtectContents Then
        ws.Unprotect Password:="123"
    End If
    
    ' Unlock the whole range anyway.
    srg.Locked = False
    srg.FormulaHidden = False
    
    If Not trg Is Nothing Then
        trg.FormulaHidden = True
        trg.Locked = True
        MsgBox "Range locked.", vbInformation, "Lock Cells in Range"
    Else
        MsgBox "Range unlocked.", vbExclamation, "Lock Cells in Range"
    End If

SafeExit:
    
    If Not ws.ProtectContents Then
        ws.Protect Password:="123", UserInterFaceOnly:=True
    End If
    Application.ScreenUpdating = True

    Exit Sub
ClearError:
    Debug.Print "Run'time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Checks if at least one of the cells in a range is locked.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function IsAnyCellLocked( _
    ByVal srg As Range) _
As Boolean
    If srg Is Nothing Then Exit Function
    Dim sCell As Range
    For Each sCell In srg.Cells
        If sCell.Locked Then
            IsAnyCellLocked = True
            Exit For
        End If
    Next sCell
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range combined from two ranges.
' Remarks:      An error will occur if 'AddRange' is 'Nothing'
'               or if the ranges are in different worksheets.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set GetCombinedRange = AddRange
    Else
        Set GetCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function