Learn to build web apps and services, IoT apps, and mobile backends by covering the fundamentals of ASP.NET Core and exploring the core foundations for app libraries.
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 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
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