Macro to lock string in cell

[msoutopico]

Hi there,

I have an Excel file with several cells containing text. The text contains some codes and I would like to know whether it's possible to lock those codes (by means of some formula or VBA macro, for example). The aim is that any text contained in the cell can be modified except those codes.

I know a whole cell can be locked/protected but I don't think it is possible to lock only part of the content of the cell. Am I right?

The codes could be matched with some regexp pattern or wildcard. E.g. The cell's content is, say: "Blabla some text [ABC_123] blabla more text blabla." I would like to lock any text being matched by regexp \[.+?\].

Thank you very much for your answers in advance!

Cheers, Manuel

 

[Rick Rothstein]

The following code should correctly lock the codes within the text in Column F for the "[[T..]]" and "(Q..)" types of code.

Dim CodeText As String, OriginalText As String

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Columns("F")) Is Nothing Then
    If CodeText <> "" Then
      If Target.Value = "Delete=Okay" Then
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
      ElseIf CodeText <> Codes(Target.Text) Then
        MsgBox "You tried change a code value which is not allowed!"
        Application.EnableEvents = False
        Target.Value = OriginalText
        Application.EnableEvents = True
      End If
    End If
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Columns("F")) Is Nothing Then
    OriginalText = Target.Value
    CodeText = Codes(Target.Value)
  End If
End Sub

Function Codes(ByVal S As String) As String
  Dim X As Long, CellText As String, Parts() As String
  ' [[T...]]
  CellText = Replace(S, "[[", "]]")
  Parts = Split(CellText, "]]")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "T*" Then Codes = Codes & "[[" & Parts(X) & "]] "
  Next
  '  (Q...)
  CellText = Replace(S, ")", "(")
  Parts = Split(CellText, "(")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "Q*" Then Codes = Codes & "(" & Parts(X) & ") "
  Next
End Function

Of course, I forgot to change the reference from Column A (where I originally had assumed your data was) to Column F where you now told us it is located. The two changes shown in red above are the changes that need to be made to address the correct column for your data.

 

[Rick Rothstein]

As for the other codes, given they can be changed within their delimiters, as long as the delimiters are not changed... that is different from barring an outright change in any part of the code, so I'll have to think about that a little more in order to determine how implement it.

Okay, I have thought about it and I believe the following event code will handle all the possible codes meeting the restrictions you set out for us in Message #9....

Dim CodeText As String, OriginalText As String

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Columns("F")) Is Nothing Then
    If CodeText <> "" Then
      If Target.Value = "Delete=Okay" Then
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
      ElseIf CodeText <> Codes(Target.Text) Then
        MsgBox "You tried change a code value which is not allowed!"
        Application.EnableEvents = False
        Target.Value = OriginalText
        Application.EnableEvents = True
      End If
    End If
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  If Not Intersect(Target, Columns("F")) Is Nothing Then
    OriginalText = Target.Value
    CodeText = Codes(Target.Value)
  End If
End Sub

Function Codes(ByVal S As String) As String
  Dim X As Long, CellText As String, Parts() As String
  ' [[T...]]
  CellText = Replace(S, "[[", "]]")
  Parts = Split(CellText, "]]")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "T*" Then Codes = Codes & "[[" & Parts(X) & "]] "
  Next
  '  (Q...)
  CellText = Replace(S, ")", "(")
  Parts = Split(CellText, "(")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "Q*" Then Codes = Codes & "(" & Parts(X) & ") "
  Next
  '  {{..}}
  CellText = Replace(S, "{{", "}}")
  Parts = Split(CellText, "}}")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "*" Then Codes = Codes & "{{*}} "
  Next
  '  <..>
  CellText = Replace(S, ">", "<")
  Parts = Split(CellText, "<")
  For X = 1 To UBound(Parts) Step 2
    If Parts(X) Like "*" Then Codes = Codes & "<*> "
  Next
End Function