Lock Certain Cells WITHOUT Protecting Worksheet

[Pacman52]

Hi,

Is there a way to lockdown certain cells with VBA without protecting the worksheet.

The reason I can't protect the worksheet is because it contains code on double click for a combobox drop down on some of the columns and every time I protect the sheet the combobox stops working. (The subs for this are below for reference)

The cells I need to lock down are
A1 to V1
B4:110

I understand from what I've read in various searches that without protecting the sheet a user could possibly change a 'locked' cell but all I am trying to do is protect a formula in the cells that they shouldn't even need to go into.

I would be very grateful for any advice or solutions offered.

Many thanks

Private Sub Worksheet_BeforeDoubleClick _
  (ByVal Target As Range, _
    Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains
      'a data validation list
    Cancel = True
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    'open the drop down list automatically
    Me.TempCombo.DropDown
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub
End Sub
Private Sub TempCombo_LostFocus()
  With Me.TempCombo
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End Sub

 

[Trevor_S]

There may be a better way ... but have you considered something like the following:

Private Sub Worksheet_Change (ByVal Target As Range)
If Target.Address = Range("A1").Address And Target.Formula <> "=B1*2" Then Target.Formula = "=B1*2"
If Target.Address = Range("A2").Address And Target.Formula <> "=B2*2" Then Target.Formula = "=B2*2"
End Sub

Replace the formulae shown in my sample code with whatever the formula in those cells should be. This will reinput the formula into these cells if they are no longer there after a change to the worksheet.

 

[Pacman52]

Hi Trevor,

Thanks for the reply and suggestion - I am a little confused though sorry my VB knowledge is basic although learning all the time thankfully.

If we exclude a need to 'lock' down A1 to V1 at the moment as there isn't actually any formula in those cells and look at my range B4:110 where the formula is referencing a lookup table.

The formula in the range B4:110 is

=IF(LEN(A4)=0,"",VLOOKUP(A4,StaffTable!$A$2:$B$500,2,FALSE))

Basically this looks up the persons name in A4 and puts the grade in B4 if its an exact match (obviously carried down to A110)


I tried replacing the text 'Formula' in your line with the actual formula and referencing the cell range but not sure if I am understanding this correctly.

This is a real pain in the **** for me at the moment as it is the last thing I need to do before completed the workbook and of course is turning out to be a nightmare to accomplish lol.

I would be really grateful if you could advise further.

Many thanks

Paul

 

[Osvaldo Palmeiro]

another approach

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Not Intersect(Target, Range("A1:V1,B4:B110")) Is Nothing Then [A2].Select
End Sub

 

[Pacman52]

Thanks Osvaldo I just tried that but it didn't seem to do anything - I do have a lot of other code in that sub though (as below) would that stop it working if I have put it in the wrong place?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim myCol As Long
    Dim rng As Range
    Dim msg As Integer
    Dim MSG2 As Integer
    Dim MSG3 As Integer
    Dim MSG4 As Integer
    Dim MSG5 As Integer
 
    Application.EnableEvents = False
    
    Set rng = Intersect(Target, Range("E4:E110"))
    If Not rng Is Nothing Then Call confirmed_canxd(rng)
    
    For Each cell In Target
        If Not Intersect(cell, Range("A4:V110")) Is Nothing Then
            myCol = cell.Column
            If (myCol = 15) Or (myCol = 16) Or (myCol = 17) Or (myCol = 21) Then
                cell = UCase(cell)
            Else
                cell = WorksheetFunction.Proper(cell.Text)
            End If
        End If
    Next cell
    Application.EnableEvents = True
    
    If Not Intersect(Target, Range("F4:F110")) Is Nothing And (Target.Value) > "" Then
        
        Beep
        
        MsgBox "Please add a Post Code for the location if you know it.", vbInformation, "Post Code"
        
        msg = MsgBox("Is a Congestion Charge payable?", vbYesNo, "Congestion Charge")
        
        If msg = vbYes Then
        
        Range("R" & Target.Row) = "Yes"
        Else
        Range("R" & Target.Row) = "No"
        
        End If
        
        MSG2 = MsgBox("Are there any mileage charges?", vbYesNo, "Mileage")
        
        If MSG2 = vbYes Then
        
        Range("S" & Target.Row) = "Yes"
        Else
        Range("S" & Target.Row) = "No"
        
        End If
       
        MSG3 = MsgBox("Are there any other charges" & vbCrLf & vbCrLf & "E.G Per Diems' Parking ect?", vbYesNo, "Misc. Charges")
        
        If MSG3 = vbYes Then
        
        MsgBox "Please add these charges and the amounts once known," & vbCrLf & "to the notes of the job.", , "Misc Charges"
        
        Range("T" & Target.Row) = "Yes"
        Else
        Range("T" & Target.Row) = "No"
        
        If Not Intersect(Target, Range("A1:V1,B4:B110")) Is Nothing Then [A2].Select
        
        
        
    End If
        End If

End Sub

 

[Osvaldo Palmeiro]

Hi.
The code I suggested should be pasted as it is into the sheet code module, below or above any other code already existing there. It's a WS_SelectionChange event not a WS.Change event.

 

[Trevor_S]

Osvaldo's method is probably better than mine, in that it stops the user even being allowed to select the locked down cells, whereas mine simply tries to revert the cell's formula back to what it was before the change.

But to clarify your query on my code example, you should have put your formula in place of the sample formula (e.g. =B1*2) that I'd used. The actual word Formula needs to remain. You'd also need a line of code for every cell you want to lock (I'd only done two lines as an example) - so you would really be better off with Osvaldo's code!

 

[Pacman52]

Hi Osvaldo - sorry I should of read the reference properly - Thank you so much that works perfectly for what I need.

 

[EssoExplJoe]

You can also color the cells that you want locked a certain color. For example, the color Yellow then in the worksheet, insert the following code

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Interior.Color = RGB(255, 255, 0) Then Range("A10").Select


End Sub