How do I prevent a user from changing the locked / unlocked format of a cell?

[XrayLemi]

Hello all,
Is there a way to make cell formatting, specifically the locked/unlocked status only possible through VBA? I want users to be able to edit a cell entry after a password is entered but not to be able to change the format of the cell.
Thank you,
Jim

 

[JoeMo]

When you protect the sheet (Home>Format>Protection) you will get a dialog box that allows you to specify whether or not the user may format unlocked cells. The user will not have any option to change the format of a locked cell when the sheet is protected if you don't check the 'Format cells' box.

.

 

[XrayLemi]

Hi Joe,
I understand that part, and it is how my sheets are set up. What I need is to make sure the format cannot be changed even if the password is entered.

 

[JoeMo]

Hi Joe,
I understand that part, and it is how my sheets are set up. What I need is to make sure the format cannot be changed even if the password is entered.

That would require VBA, probably using both Selection_Change and Change event code to detect and reformat any cell the user changes the format.

 

[XrayLemi]

So, I guess that is a round about way of saying that once a password is entered there is no way to prevent a user from changing a cell format. Even with VBA. The best that can be done is to use VBA to put back the format once it has been altered by the user. Is that correct?

 

[JoeMo]

So, I guess that is a round about way of saying that once a password is entered there is no way to prevent a user from changing a cell format. Even with VBA. The best that can be done is to use VBA to put back the format once it has been altered by the user. Is that correct?

I have no direct experience with this, but I believe that's correct. But the "put back" would occur almost contemporaneously with the alteration and would take place without your intervention, being triggered by the user's actions.

 

[XrayLemi]

Okay, thanks for the info. I'll leave this open for a while. Maybe someone else will see this and confirm your hypothesis. I was hoping for an easy fix. I guess not this time.
Best,
Jim

 

[XrayLemi]

Okay, so I need to fix my code in the manner you had proposed. This is above my ability in VBA programing. I have the problem of needing to know chapter 10 before I learn chapter 2. I hope you can bear with me.

I am assuming the code you a referring to goes in the worksheet module. This is the code I have on all my sheets. Allot of it came from people here. the rest was...... copy from the internet, paste, make it work.

Dim old
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Cells.CountLarge > 1 Then
        MsgBox "Sorry, multiple selections are not allowed.", vbCritical
        ActiveCell.Select
    End If
    If Target.Cells.CountLarge = 1 Then
     If Not Intersect(Target, Range("A1:L1048576, N1:XFD1048576")) Is Nothing Then
      old = Target.Value
     End If
    End If
End Sub

Private Sub CommandButton1_Click()
    UpdateDataFromMasterFile
End Sub

Private Sub CommandButton2_Click()
maint_form.Show
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim r As Range, c As Range
  Set r = Union(Range("J6:J5000"), Range("G6:G5000"))
  Set r = Intersect(Target, r)
  If Not r Is Nothing Then
   Application.EnableEvents = False
   For Each c In r
    Select Case True
       Case 10 = c.Column 'J
        If c.Value = "" Then
          Cells(c.Row, "L").Value = ""
          Cells(c.Row, "L").Locked = True
          Else
          Cells(c.Row, "L").Locked = False
        End If
       Case 7 = c.Column 'G
        If c.Value = "Not Listed" Then
          Cells(c.Row, "H").Locked = False
          Else
          Cells(c.Row, "H").Locked = True
          Cells(c.Row, "H").Value = ""
        End If
       Case Else
    End Select
   Next c
  End If
  
If Target.Cells.Count > 3 Then Exit Sub
  If Not Intersect(Target, Range("C6:C5000")) Is Nothing Then
   With Target(1, 3)
    .Value = Date
    .EntireColumn.AutoFit
   End With
  End If
 
    Dim p As Range, z As Range
     Set p = Range("M6:M5000")
     Set p = Intersect(Target, p)
     If Not p Is Nothing Then
   Application.EnableEvents = False
     For Each z In p
      Select Case True
       Case 13 = z.Column 'M
        If z.Value <> "" Then
         Check = MsgBox("Are your entries correct?" & vbCrLf & "After entering yes, These values CANNOT be changed.", vbYesNo + vbQuestion, "Cell Lock Notification")
           If Check = vbYes Then
            Target.Rows.EntireRow.Locked = True
            Cells(z.Row + 1, "B").Locked = False
            Cells(z.Row + 1, "C").Locked = False
            Cells(z.Row + 1, "D").Locked = False
            Cells(z.Row + 1, "E").Locked = False
            Cells(z.Row + 1, "F").Locked = False
            Cells(z.Row + 1, "G").Locked = False
            Cells(z.Row + 1, "I").Locked = False
            Cells(z.Row + 1, "J").Locked = False
            Cells(z.Row + 1, "K").Locked = False
            Cells(z.Row + 1, "M").Locked = False
            If Cells(z.Row, "Q").Value <> "" Then Copyemail 'Q
            If Cells(z.Row, "R").Value <> "" Then ThisWorkbook.Save 'R
            With Me
                .Parent.Activate
                .Activate
                .Range("B" & Rows.Count).End(xlUp).Offset(1).Activate
            End With
           Else
            Cells(z.Row, "M").Value = ""
           End If
          End If
      Case Else
    End Select
   Next z
 End If
 
   If Target.CountLarge > 1 Then
    End If
    If Not Intersect(Target, Range("A1:L1048576, N1:XFD1048576")) Is Nothing Then
      If Target.Locked = True Then
          With Application
           .EnableEvents = False
            With ThisWorkbook.Worksheets("Sheet2").UsedRange.Rows
            Sheets("Sheet2").Unprotect "password"
             .Item(.Count + 1).Columns("B").Value = old
             .Item(.Count + 1).Columns("C").Value = Target.Value
             .Item(.Count + 1).Columns("D").Value = Environ("username")
             .Item(.Count + 1).Columns("E").Value = Now
             .Item(.Count + 1).Columns("F").Value = Target.Row
             .Item(.Count + 1).Columns("G").Value = Target.Column
              .Item(.Count + 1).Columns("H").Value = ActiveSheet.Name
            End With
                Application.ScreenUpdating = False
                Dim outlookApp As Object
                Dim myMail As Object
                Set outlookApp = CreateObject("Outlook.Application")
                Set myMail = outlookApp.CreateItem(0)
                myMail.To = "person@acompany.net"
                myMail.Subject = "Changes made"
                myMail.HTMLBody = "Changes to file " & Application.ActiveWorkbook.FullName
                myMail.send
             .EnableEvents = True
          End With
      End If
    End If
       Sheets("Sheet2").Protect "password"
 Application.EnableEvents = True
End Sub

I tried something like this .......

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim V(1)
        If Target.CountLarge > 1 Then Exit Sub
    If Target.Locked = True Then
        With Application
          .EnableEvents = False
             V(1) = Target.Value
          .Undo
             V(0) = Target.Value   
          .EnableEvents = True
        End With
    End If
End Sub

This works fine for values within a cell, but cell formatting is done "behind the scenes" and I am not sure where to go with that. I also don't need the formatting recorded like the cell values.
Thanks again,
Jim

 

[JoeMo]

After thinking about this a bit more, what I had in mind won't work. In any case, if something could be done it would have to be merged with your current Selection_change and Change procedures.

 

[XrayLemi]

Hey JoeMo,
I don't know if you're still watching this but I came up with a great work around. I used allow edit ranges. I gave the range one password, and the sheet another password. Now Those who need to, can edit a cell in that range but they cannot change the format since the sheet is protected with another password.