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

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个错误单元集合，以识别未锁定的单元格范围。

关键代码步骤如下：

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

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

根据this Microsoft KB article，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 the个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

Answer 2

使用条件格式： - 使用公式确定要格式化的单元格，格式化此公式为真的值：=CELL("protect",A1)=0和应用于占用范围的选择格式？

Answer 3

好吧，我已经回到循环中，但我认为这种方法很有效，因为它只使用下一步引用Unlocked（未选择）的单元格：

  

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

     

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

它存储第一个（下一个）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

Answer 4

我正在寻找一种清除未锁定细胞内容的方法。问题是我的表单有数百个（如果不是数千个）未锁定的单元格和两倍的锁定单元格。迭代它们需要大约5-7秒，我想要更高效的东西。

brettdj的解决方案让我走了一半，但在我的范围内有这么多的细胞打破了这个算法。

该行

Set rng3 = ws1.Range(rng2.Address)

因为rng2的地址超过了256个字符的限制而没有工作，所以rng3变成了＃34;没有＆＃34;。

我花了好几个小时试图解决256限制但无处可去。几乎放弃后，我偶然发现了＆＃34;区域＆＃34;范围的对象。救生员！

以下调整后的代码适用于具有多个未锁定单元格的工作表。感谢brettdj最初的想法。

' Sub to clear unlocked cells.
Sub clearUnlockedCells()
   On Error Resume Next
   ' If the Workbook is protected, unlock it.
   Dim workbook_protected As Boolean
   If ActiveWorkbook.ProtectStructure Then
      workbook_protected = True
      ActiveWorkbook.Unprotect

      ' If we failed to unlock the Workbook, error out and exit.
      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
      End If
   End If

   Dim source_sheet As Worksheet
   Set source_sheet = ActiveSheet
   ' If the Worksheet is protected, unlock it.
   Dim worksheet_protected As Boolean
   If source_sheet.ProtectContents Then
      worksheet_protected = True
      source_sheet.Unprotect

      ' If we failed to unlock the Worksheet, error out and exit.
      If source_sheet.ProtectContents Then
         MsgBox "Sorry, I could not remove the passsword protection from sheet" & vbNewLine & source_sheet.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.
   ' Store the calculation and set it to manual.
   Dim calc As Long
   With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
      calc = .Calculation
      .Calculation = xlCalculationManual
   End With

   On Error Resume Next
   ' Check for existing error cells.
   Dim tmp_rng As Range
   Set tmp_rng = source_sheet.Cells.SpecialCells(xlCellTypeFormulas, 16)
   On Error GoTo 0

   ' Copy the ActiveSheet to a new working sheet.
   source_sheet.Copy After:=Sheets(Sheets.Count)
   Dim tmp_sheet As Worksheet
   Set tmp_sheet = ActiveSheet
   ' Delete any cells that already contain errors.
   If Not tmp_rng Is Nothing Then tmp_sheet.Range(tmp_rng.Address).ClearContents

   ' Protect the new sheet and add an error formula to all unlocked cells in the 
   ' used range, then use SpecialCells to read the unlocked range address.
   tmp_sheet.Protect
   On Error Resume Next
   tmp_sheet.UsedRange.Formula = "=NA()"
   tmp_sheet.Unprotect

   ' Get the range of cells with "=NA()" in them.
   Set tmp_rng = tmp_sheet.Cells.SpecialCells(xlCellTypeFormulas, 16)

   ' Iterate through the range and create a mirror of that range in the source sheet.
   Dim area As Range
   Dim source_sheet_range As Range
   Dim unlocked_cells As Range
   For Each area In tmp_rng.Areas
      Set source_sheet_range = source_sheet.Range(area.Address)
      If unlocked_cells Is Nothing Then
         Set unlocked_cells = source_sheet_range
      Else
         Set unlocked_cells = Union(unlocked_cells, source_sheet_range)
      End If
   Next area

   ' Delete the temp sheet.
   tmp_sheet.Delete

   On Error GoTo 0

   ' Protect the Workbook and Worksheet as necessary.
   If workbook_protected Then ActiveWorkbook.Protect
   If worksheet_protected Then source_sheet.Protect

   ' Cleanup user interface and settings.
   With Application
      .ScreenUpdating = True
      .EnableEvents = True
      .DisplayAlerts = True
      .Calculation = calc
   End With

   ' Clean up the unlocked cells.
   unlocked_cells.ClearContents
End Sub

希望能帮到别人。如果您只想选择它们而不是清除它们，那么将.ClearContents中的第二行更改为.Select。

Answer 5

我正在探索这个问题，但是我或多或少地接受了布雷特的方法。稍有不同的是我使用当前的工作表而不是创建一个新工作表。我最初也假设工作表中没有错误。 （可以添加类似于Brett的代码来解释这些问题。）

我想用“#N / A”充斥UsedRange，忽略错误，然后使用Application.Undo快速返回。不幸的是，我无法使用Undo（与Word不同）。所以我使用Variant来获取整个区域的数据，然后重新插入它。

Sub GetUnlockedCells()
    Dim ws As Worksheet
    Dim rngUsed As Range
    Dim varKeep As Variant

    Application.ScreenUpdating = False
    Set ws = Worksheets(1)
    ws.Protect
    Set rngUsed = ws.UsedRange
    varKeep = rngUsed.Value
    On Error Resume Next
    rngUsed.Value = "#N/A"
    On Error GoTo 0
    ws.Unprotect
    MsgBox "Unlocked cells are " & _
        rngUsed.SpecialCells(xlCellTypeConstants, xlErrors).Address
    rngUsed.Value = varKeep
    Application.ScreenUpdating = True
End Sub

所以，不幸的是，我没有超越Brett的酷代码。也许它会激励别人，或者有人可能会发现使用撤销的方法;）

我也失去了公式（转换为值）所以需要一些工作！

Answer 6

如果有很多公式，一般方法是

For each row in ...
  lockedR = row.locked
  for each cell in row
     if isnull(lockedR) then ' inconsistent in row
        locked = cell.locked
     else 
        locked = lockedR ' consistent from row, no need to get it.

此模式适用于许多属性，例如HasArray。但是对于Locked而言，它的速度要慢得多（100倍）。不知道为什么这么低效。

转到特别是一个可爱的伎俩，但没有锁定的细胞。

一个好的解决方案会很棒，但我怀疑是不可能的。

Answer 7

这是一种通用解决方案，它比在单元格范围内循环要快得多，比克隆临时工作表等要简单得多，直接得多。它相对较快，因为它利用了Excel中的高速编译代码VBA的Find方法已实现。

Function GetUnlockedCells(SearchRange As Range) As Range 'Union
    '
    'Finds all unlocked cells in the specified range and returns a range-union of them.
    '
    'AUTHOR: Peter Straton
    '
    '*************************************************************************************************************

    Dim FoundCell As Range
    Dim FirstCellAddr As String
    Dim UnlockedUnion As Range

    'NOTE: When finding by format, you must first set the FindFormat specification:

    With Application.FindFormat
        .Clear
        .Locked = False 'This is the key to this technique
    End With

    'NOTE: Unfortunately, the FindNext method does not remember the SearchFormat:=True specification so it is
    'necessary to capture the address of the first cell found, use the Find method (instead) inside the find-next
    'loop and explicitly terminate the loop when the first-found cell is found a second time.

    With SearchRange
        Set FoundCell = .Find(What:="", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
                              SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
                              SearchFormat:=True)
        If Not FoundCell Is Nothing Then
            FirstCellAddr = FoundCell.Address
            Do
'                Debug.Print FoundCell.Address
                If UnlockedUnion Is Nothing Then
                    Set UnlockedUnion = FoundCell.MergeArea                         'Include merged cells, if any
                Else
                    Set UnlockedUnion = Union(UnlockedUnion, FoundCell.MergeArea)   '           "
                End If

                Set FoundCell = .Find(What:="", After:=FoundCell, SearchDirection:=xlNext, SearchFormat:=True)
            Loop Until FoundCell.Address = FirstCellAddr
        End If
    End With
    Application.FindFormat.Clear        'Cleanup

    Set GetUnlockedCells = UnlockedUnion
End Function 'GetUnlockedCells