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

Question

在线论坛中的一个常见请求是提供代码来识别工作表中未锁定的单元格。

标准解决方案使用循环来迭代事件工作表的已使用部分中的每个单元格，测试每个单元格以确定它是否被锁定。一个code sample下面列出了此方法的详细信息。

鉴于循环单元格范围固有的较差性能，有哪些更好的方法是可能的？

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

识别未锁定单元格的范围方法

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 集合来标识解锁的单元格范围。

关键代码步骤是:

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

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

根据 this Microsoft KB article 、Excel-2007及更早版本通过VBA宏最多支持8,192个非连续单元格。令人惊讶的是，将 VBA 宏应用于这些 Excel 版本中超过 8192 个 SpecialCells 区域不会引发错误消息，并且正在考虑的整个区域将被视为 SpecialCells 范围集合的一部分.

快速解锁代码

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