Vba If cell contains specific word, lock it.

[pontiff]

Hi all,
Looking for some vba that will lock any cell on a sheet containing the text “xxxxx” when I select the protect sheet option. These cells are important as they act as a “target” for some other vba so need to be protected. They also move position.
Thanks in advance

 

[Joe4]

Here is one way:

Sub MyLockMacro()

    Dim myFindString As String
    Dim cell As Range
    Dim lr As Long
    Dim nr As Long
    
'   Indicate value to look for
    myFindString = "xxxxx"

    Range("A1").Select

    Application.ScreenUpdating = False

'   Create loop to look for all instances
    Do
'       Find next instance
        Set cell = Cells.Find(What:=myFindString, After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False)
'       Exit loop if cannot find value
        If cell Is Nothing Then
            Exit Do
        Else
'           Capture new row value found on
            nr = cell.Row
'           Check to see if new row is less than previous row
            If nr < lr Then
                Exit Do
            Else
'               Lock found cell
                cell.Activate
                cell.Locked = True
'               Update last cell found
                lr = nr
            End If
        End If
    Loop

    Application.ScreenUpdating = True
    
    MsgBox "Macro complete!"
    
End Sub

 

[pontiff]

Here is one way:

Sub MyLockMacro()

    Dim myFindString As String
    Dim cell As Range
    Dim lr As Long
    Dim nr As Long
   
'   Indicate value to look for
    myFindString = "xxxxx"

    Range("A1").Select

    Application.ScreenUpdating = False

'   Create loop to look for all instances
    Do
'       Find next instance
        Set cell = Cells.Find(What:=myFindString, After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=False)
'       Exit loop if cannot find value
        If cell Is Nothing Then
            Exit Do
        Else
'           Capture new row value found on
            nr = cell.Row
'           Check to see if new row is less than previous row
            If nr < lr Then
                Exit Do
            Else
'               Lock found cell
                cell.Activate
                cell.Locked = True
'               Update last cell found
                lr = nr
            End If
        End If
    Loop

    Application.ScreenUpdating = True
   
    MsgBox "Macro complete!"
   
End Sub

Thanks so much for this, I’ll try it out tonight and get back to you. Much appreciated!