CODEWITHSUNDEEP
excelvba
brettdj
brettdj

Reputation: 55702

Fast method for determining unlocked cell range

A common request in the online forums is for code to identify the unlocked cells within a sheet.

The standard solutions use a loop to iterate through each cell in the used portion of the active worksheet, testing each cell determine if it is locked or not. A code sample for this approach is listed below.

Given the inherent poor performance in looping through cell ranges what superior approaches are possible?

(NB: I do intend to add my own existing approach which was previously hosted on another forum as a potential approach - but I will accept another [suitable] method as the answer if it is provided)

Range Approach to identify unlocked cells

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

Upvotes: 8

Views: 6212

Answers (7)

pstraton
pstraton

Reputation: 1120

Here's a general solution that is much faster than looping through ranges of cells and is much simpler, more straightforward, than cloning temporary worksheets, etc. It is relatively fast because it takes advantage of the high-speed compiled code in which Excel VBA's Find method is implemented.

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

Upvotes: 1

Tuntable
Tuntable

Reputation: 3574

If there are lots of formulas, general approach is

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.

This pattern works fine for many properties such as HasArray. But just for Locked it is grossly (100 times) slower. Don't know why so inefficient.

Goto Special would be a cute trick, but there isn't one for locked cells.

A good solution would be wonderful but I suspect impossible.

Upvotes: 0

Andy G
Andy G

Reputation: 19367

Well, I've gone back to a loop, but I think this method is efficient because it only references those cells which are Unlocked (without selecting) using Next:

If the object is a range, this property emulates the TAB key, although the property returns the next cell without selecting it.

On a protected sheet, this property returns the next unlocked cell. On an unprotected sheet, this property always returns the cell immediately to the right of the specified cell.

It stores the first (Next) Range.Address, loops through the others until it returns to this first one.

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

Upvotes: 5

Zo_
Zo_

Reputation: 51

I was looking for a way to clear the contents of my unlocked cells. The problem was that my sheet has hundreds, if not thousands, of unlocked cells and twice as many locked ones. Iterating through them was taking about 5-7 seconds and I wanted something more efficient.

brettdj's solution got me half way there, but having so many cells in my range broke the algorithm.

The line

Set rng3 = ws1.Range(rng2.Address)

Was not working because rng2's address was over the 256 character limit, so rng3 became "nothing".

I spent hours trying to work around the 256 limit but got nowhere. After almost giving up, I stumbled upon the "areas" object of a range. Life saver!

The adjusted code below works with sheets that have several unlocked cells. Thanks to brettdj for the original idea.

' 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

Hope that helps someone else. If you just want to select them instead of clearing them, then change the second to last line from .ClearContents to .Select.

Upvotes: 1

Andy G
Andy G

Reputation: 19367

I was exploring this but I've come full-circle to, more or less, Brett's approach. The slight difference is that I use the current worksheet rather than creating a new one. I'm also initially assuming that there are no errors in the worksheet. (Code could be added similar to Brett's to account for these.)

I wanted to flood the UsedRange with "#N/A", ignore errors, and use Application.Undo to quickly get back. Unfortunately, I couldn't use Undo (unlike in Word). So I resorted to using a Variant to grab the whole area's data, and then re-insert it.

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

So, unfortunately, I haven't advanced much beyond Brett's cool code. Maybe it will inspire someone else, or someone might discover a way to use Undo ;)

I'm also losing formulas as well (converted to values) so some work required!

Upvotes: 0

pnuts
pnuts

Reputation: 59495

Use Conditional Formatting with:- Use a formula to determine which cells to format, Format values where this formula is true: =CELL("protect",A1)=0 and Format of choice applied to occupied range?

Upvotes: 4

brettdj
brettdj

Reputation: 55702

Using SpecialCells to quickly identify unlocked cells

The code below - QuickUnlocked - uses a workaround to quickly generate a SpecialCells collection of error cells to identify the unlocked cell range.

The key code steps are:

  • Alter the Application to suppress errors, code and screenupdating
  • Attempt to unlock the ActiveWorkbook and/or the ActiveSheet if they are protected. Exit the code if unsuccessful
  • Make a replica of the current sheet
  • Delete any existing formula errors in the replica using SpecialCells
  • Protect the replica worksheet and with the coverage of error handling, add a deliberate formula error that will only populate the unlocked cells
  • Clean up and report the results Reset the Application settings

Warning that SpecialCells is restricted to 8192 Areas prior to Xl2010

As per this Microsoft KB article, Excel-2007 and earlier versions supports up to a maximum of 8,192 non-contiguous cells through VBA macros. Rather surprisingly, applying a VBA macro to more than 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` range collection.

Quick Unlocked code

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

Upvotes: 8

Related Questions