Macro para borrar las celdas desbloqueadas

Esta macro que estoy usando para borrar las celdas desbloqueadas:

Sub Borrar_CELDAS_Desbloqueadas()
ActiveSheet.Protect Password:="1"
Application.ScreenUpdating = False ' Apagar el parpadeo de pantalla
Dim r As Range
For Each r In Selection
If r.Locked = False Then r.ClearContents
Dim img As Shape
On Error Resume Next
For Each img In ActiveSheet.Shapes
If Not Application.Intersect(img.TopLeftCell, Selection) Is Nothing Then
If img.Type = msoPicture Then img.Delete
End If
Next
Next
End Sub

Me resulta muy lenta, la pregunta es:
¿Se podría hacer más rápida?
Un saludo