确定解锁细胞范围的快速方法
在线论坛中的一个常见请求是用于识别工作表内未locking单元格的代码。
标准解决scheme使用循环遍历活动工作表使用部分中的每个单元格，testing每个单元格确定它是否被locking。 下面列出了这种方法的代码示例 。
考虑到循环遍历单元格范围的内在差的性能，可能有哪些优越的方法？
（注：我打算join我以前在另一个论坛上主持的现有方法，作为一种潜在的方法 – 但是如果提供的话，我会接受另一种适当的方法作为答案）
范围方法来识别解锁的单元格
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 那么，我已经回到了一个循环，但我认为这种方法是有效的，因为它只引用那些被Unlocked （没有select）的单元格使用Next ：
如果对象是一个范围，此属性模拟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
使用SpecialCells快速识别解锁的单元格
下面的代码 – QuickUnlocked – 使用一种解决方法来快速生成一个SpecialCells错误单元集合来标识未locking的单元格范围。
关键的代码步骤是：
- 改变
Application来抑制错误，代码和屏幕更新 - 尝试解锁
ActiveWorkbook和/或ActiveSheet如果他们受到保护。 退出代码如果不成功 - 制作当前工作表的副本
- 使用
SpecialCells删除副本中的所有现有公式错误 - 保护副本工作表和覆盖的error handling，添加故意的公式错误，将只填充未locking的单元格
- 清理并报告结果重置应用程序设置
警告SpecialCells限制在Xl2010之前的8192个地区
根据此Microsoft知识库文章 ，Excel-2007和更早版本最多可通过VBAmacros支持最多8,192个不连续的单元。 相当令人吃惊的是， 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应用一个VBAmacrosSpecialCells 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
使用条件格式： – 使用公式来确定要格式化的单元格，格式化公式为真的值： =CELL("protect",A1)=0 ，select的格式应用于占用的范围？
我正在寻找一种方法来清除我解锁的单元格的内容。 问题是我的工作表有几百个（如果不是数千个）未locking的单元格和两倍的locking单元格。 迭代通过他们大约需要5-7秒，我想要更有效率的东西。
brettdj的解决scheme让我有一半的路程，但是在我的范围内有这么多的细胞打破了algorithm。
该线
Set rng3 = ws1.Range(rng2.Address)
因为rng2的地址超过了256个字符的限制，所以rng3变成了“没有”。
我花了几个小时试图绕过256的限制，但没有得到任何好处。 几乎放弃之后，我偶然发现了一个范围的“区域”对象。 拯救生命！
下面调整的代码适用于具有多个解锁单元的表单。 感谢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
希望能帮助别人。 如果您只想select它们而不是清除它们，则将第二行最后一行从.ClearContents更改为.Select。
我正在探索这个问题，但是我已经或多或less的全面了解了Brett的方法。 略有不同的是，我使用当前的工作表，而不是创build一个新的。 我最初也假定在工作表中没有错误。 （可以添加类似于Brett的代码来解释这些）。
我想用“ UsedRange / A”泛滥UsedRange ，忽略错误，并使用Application.Undo快速返回。 不幸的是，我不能使用Undo （不像在Word中）。 所以我使用了一个变体来获取整个区域的数据，然后重新插入它。
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的酷代码。 也许会激发别人，或者有人可能会发现一种方法来使用撤消;）
我也失去了公式（转换为值），所以需要一些工作！