Sub TypicalUnlocked()
Dim rng1 As Range
Dim rng2 As Range
For Each rng1 In ActiveSheet.UsedRange
If Not rng1.Locked Then
If rng2 Is Nothing Then
Set rng2 = rng1
Else
Set rng2 = Union(rng2, rng1)
End If
End If
Next rng1
If rng2 Is Nothing Then
MsgBox "No unlocked cells in " & ActiveSheet.Name
Else
MsgBox "Unlocked range is " & rng2.Address(0, 0)
End If
End Sub
As per my comments in Using Variant Arrays in Excel VBA for Large Scale Data Manipulation, For … Next loops though ranges can often produce significant bottlenecks for developers. In this particular case, SpecialCells offers a quick alternative for indentifying the unlocked cell range.
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
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
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (0)