确定未锁定单元格范围的快速方法

Question

在线论坛中的一个常见请求是用于识别表单中未锁定单元格的代码.

标准解决方案使用循环迭代活动工作表的已使用部分中的每个单元格,测试每个单元格确定它是否被锁定.甲代码示例这种方法在下面列出.

鉴于在循环细胞范围内固有的差的性能,可能有哪些优越的方法？

(注意:我确实打算添加我自己现有的方法,以前作为潜在的方法托管在另一个论坛上 - 但如果提供的话,我将接受另一个[合适的]方法作为答案)

范围识别未锁定细胞的方法

Sub SelectUnlockedCells()
`http://www.extendoffice.com/documents/excel/1053-excel-identify-select-locked-cells.html
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
On Error GoTo SelectUnlockedCells_Error

Set WorkRange = ActiveSheet.UsedRange
For Each Cell In WorkRange
    If Cell.Locked = False Then
        If FoundCells Is Nothing Then
            Set FoundCells = Cell
        Else
            Set FoundCells = Union(FoundCells, Cell)
        End If
    End If
Next Cell
If FoundCells Is Nothing Then
    MsgBox "All cells are locked."
Else
    FoundCells.Select
End If

On Error GoTo 0
Exit Sub

SelectUnlockedCells_Error:
   MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure     
SelectUnlockedCells of Module Module1"
End Sub

Answer 1

使用SpecialCells快速识别解锁细胞

下面的代码 - QuickUnlocked - 使用变通方法快速生成SpecialCells错误单元格集合,以识别未锁定的单元格范围.

关键代码步骤是:

• 改变Application以抑制错误,代码和屏幕更新
• 尝试解锁ActiveWorkbook和/或ActiveSheet它们是否受到保护.如果不成功则退出代码
• 制作当前工作表的副本
• 使用删除副本中的任何现有公式错误 SpecialCells
• 保护副本工作表和错误处理的覆盖范围,添加一个故意的公式错误,只会填充未锁定的单元格
• 清理并报告结果重置应用程序设置

警告SpecialCells仅限于Xl2010之前的8192个区域

根据Microsoft KB文章,Excel-2007和早期版本通过VBA宏最多支持最多8,192个非连续单元.相当令人惊讶的是,将VBA宏应用于超过8192个SpecialCells Areas in these Excel versions, will not raise an error message, and the entire area under consideration will be treated as being part of theSpecialCells`范围集合.

快速解锁代码

Sub QuickUnlocked()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim lCalc As Long
    Dim bWorkbookProtected As Boolean

    On Error Resume Next
    'test to see if WorkBook structure is protected
    'if so try to unlock it
    If ActiveWorkbook.ProtectStructure Then
        ActiveWorkbook.Unprotect
        If ActiveWorkbook.ProtectStructure Then
            MsgBox "Sorry, I could not remove the passsword protection from the workbook" _
                 & vbNewLine & "Please remove it before running the code again", vbCritical
            Exit Sub
        Else
            bWorkbookProtected = True
        End If
    End If

    Set ws1 = ActiveSheet
    'test to see if current sheet is protected
    'if so try to unlock it
    If ws1.ProtectContents Then
        ws1.Unprotect
        If ws1.ProtectContents Then
            MsgBox "Sorry, I could not remove the passsword protection from sheet" & vbNewLine & ws1.Name _
                 & vbNewLine & "Please remove it before running the code again", vbCritical
            Exit Sub
        End If
    End If
    On Error GoTo 0

    'disable screenupdating, event code and warning messages.
    'set calculation to manual
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    On Error Resume Next
    'check for existing error cells
    Set rng1 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
    On Error GoTo 0

    'copy the activesheet to a new working sheet
    ws1.Copy After:=Sheets(Sheets.Count)
    Set ws2 = ActiveSheet
    'delete any cells that already contain errors
    If Not rng1 Is Nothing Then ws2.Range(rng1.Address).ClearContents

    'protect the new sheet
    ws2.Protect
    'add an error formula to all unlocked cells in the used range
    'then use SpecialCells to read the unlocked range address
    On Error Resume Next
    ws2.UsedRange.Formula = "=NA()"
    ws2.Unprotect
    Set rng2 = ws2.Cells.SpecialCells(xlCellTypeFormulas, 16)
    Set rng3 = ws1.Range(rng2.Address)
    ws2.Delete
    On Error GoTo 0

    'if WorkBook level protection was removed then reinstall it
    If bWorkbookProtected Then ActiveWorkbook.Protect

    'cleanup user interface and settings
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        lCalc = .Calculation
    End With

    'inform the user of the unlocked cell range
    If Not rng3 Is Nothing Then
        MsgBox "The unlocked cell range in Sheet " & vbNewLine & ws1.Name & " is " & vbNewLine & rng3.Address(0, 0)
    Else
        MsgBox "No unlocked cells exist in " & ws1.Name
    End If

End Sub

Answer 2

好吧，我已经回到了一个循环，但我认为这种方法是有效的，因为它只引用那些Unlocked使用Next 的单元格（不选择）：

如果对象是一个范围，则此属性模拟 TAB 键，尽管该属性返回下一个单元格而不选择它。

在受保护的工作表上，此属性返回下一个未锁定的单元格。在未受保护的工作表上，此属性始终返回紧靠指定单元格右侧的单元格。

它存储第一个 (Next) Range.Address，循环遍历其他的直到它返回到第一个。

Sub GetUnlockedCells_Next()
    Dim ws As Worksheet
    Dim strFirst As String
    Dim rngNext As Range
    Dim strLocked As String

    Set ws = Worksheets(1)
    ws.Protect
    Set rngNext = ws.Range("A1").Next
    strFirst = rngNext.Address
    Do
        strLocked = strLocked & rngNext.Address & ","
        Set rngNext = rngNext.Next
    Loop Until rngNext.Address = strFirst
    strLocked = Left(strLocked, Len(strLocked) - 1)     'remove the spare comma
    ws.Range(strLocked).Select
    ws.Unprotect
    MsgBox strLocked
End Sub