A small adjustment needed to an existing code

[palaeontology]

Hi, I'm currently using the following code ... it allows me to double click on a cell in the range A8:A400, which then transfers the data from that cell over to the first available cell of a different sheet in the range LeftSubject!A8:A400. If double clicked again, it undoes that action.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Dim LS As Range, c As Range, MySwitch As Boolean


    If Intersect(Target, Range("A8:A400")) Is Nothing Then Exit Sub
    Set LS = Sheets("LeftSubject").Range("A8:A400")
    
    If Target.Interior.ColorIndex = 3 Then
        Target.Interior.ColorIndex = xlNone
        MySwitch = False
        For Each c In LS
            If c.Value = Target.Value Or MySwitch Then
                c.Value = c.Offset(1, 0).Value
                c.Offset(0, 4).Value = c.Offset(1, 4).Value
                MySwitch = True
            End If
            If c.Value = "" Then Exit Sub
        Next c
    Else
        Target.Interior.ColorIndex = 3
        Set c = LS.Offset(-1).Find("")
        c.Value = Target.Value
        c.Offset(0, 4) = Now
    End If
    
End Sub

However, the cells that the user might double click on (ie: range A8:A400 of the worksheet where the code is saved) I need them to be password protected, but, of course, the current code (shown above) doesn't work if those cells are protected.

Is there something I can add to the code that, in the act of double clicking, undoes the password, carries out the required action, then puts the password protection back into place ?

The password is ... Malibu00 ... if you need it for the code.

Very kind regards,

Chris

 

[palaeontology]

Hi Peter,

I've had so many threads, I lost track of this one, my apologies.

Yes, I have a trillion codes in this workbook, but none of them are worksheet_Change events.

When I get the pop-up message appearing, it's not saying there's an error, it's simply saying ... "The cell or chart you're trying to change is on a protected sheet. To make changes, click Unprotect Sheet in the Review tab (you might need a password)."

So, there's no debug that's highlighted. I simply click away from the pop-up message, and it disappears, but a new user might not know to do that, so I'm trying to avoid that potential confusion.

If there's no code to prevent that pop-up from appearing, that's not a problem.

Very kind regards,

Chris

 

[Peter_SSs]

When I get the pop-up message appearing, it's not saying there's an error, it's simply saying ... "The cell or chart you're trying to change is on a protected sheet. To make changes, click Unprotect Sheet in the Review tab (you might need a password)."

So, there's no debug that's highlighted. I simply click away from the pop-up message, and it disappears, but a new user might not know to do that, so I'm trying to avoid that potential confusion.

Ahhh, my mistake.
I have a different setting to you in my Excel Options so I wasn't getting that pop-up - but I should have known to include an extra line of code. Add this blue one in where shown.

If Not Intersect(Target, Range("A8:A400")) Is Nothing Then
  Cancel = True
  ActiveSheet.Unprotect Password:="Malibu00"

 

[palaeontology]

as always, that worked a treat.

Thankyou, so much, Peter.

Kind regards,

Chris

 

[Peter_SSs]

as always, that worked a treat.

Thankyou, so much, Peter.

Kind regards,

Chris

No problem. Sorry it took me so long to cotton on to the issue.

 

[palaeontology]

Not at all. I needed to improve my explanation.

Kindest regards from Brisbane to Macksville,

Chris

 

[palaeontology]

OK, I'm having a new issue with the code.

Here's the current code ...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim wsLS As Worksheet
  Dim NextCell As Range, Found As Range
  
  If Not Intersect(Target, Range("A8:A400")) Is Nothing Then
  Cancel = True
    ActiveSheet.Unprotect Password:="Malibu00"
    Set wsLS = Sheets("LeftSubject")
    wsLS.Unprotect Password:="Malibu00"
    If Target.Interior.ColorIndex = 3 Then
      Target.Interior.ColorIndex = xlNone
      Set Found = wsLS.Columns("A").Find(What:=Target.Value, LookAt:=xlWhole)
      If Not Found Is Nothing Then Found.Resize(, 5).Delete Shift:=xlUp
    Else
      Target.Interior.ColorIndex = 3
      Set NextCell = wsLS.Cells(wsLS.Rows.Count, "A").End(xlUp).Offset(1)
      NextCell.Value = Target.Value
      NextCell.Offset(0, 4) = Now
    End If
    ActiveSheet.Protect Password:="Malibu00"
    wsLS.Protect Password:="Malibu00"
  End If
End Sub

It's doing everything brilliantly, however, when I double click a cell that is currently already highlighted red (because that student's data has previously been moved over to the sheet 'LeftSubject') .... ie: I'm trying to remove that value from it's location in 'LeftSubject' ... all the formulae I have in LeftSubject!F8:NZ400, that feed from the corresponding cell value in LeftSubject!A8:A400, seem to get affected.

For example, if I double click an existing red cell somewhere in Entry!A8:A400, that corresponding entry is removed from it's location somewhere in LeftSubject!A8:A400 ... but .... the formula in every cell in the range LeftSubject!F8:NZ8 changes from this ...

=IFERROR(IF(INDEX(Entry!$A$8:$NY$400,MATCH($A8,Entry!$A$8:$A$400,0),COLUMN()-1)="","",INDEX(Entry!$A$8:$NY$400,MATCH($A8,Entry!$A$8:$A$400,0),COLUMN()-1)),"")

to

=IFERROR(IF(INDEX(Entry!$A$8:$NY$400,MATCH(#REF ,Entry!$A$8:$A$400,0),COLUMN()-1)="","",INDEX(Entry!$A$8:$NY$400,MATCH(#REF ,Entry!$A$8:$A$400,0),COLUMN()-1)),"")

the next row down (row 9) then takes on the formula that used to be in row 8 (the one shown above).

If I double click a second red cell from Entry!A8:A400, the formula in row 9 then changes to a formula with #REF (like the one above), and row 10 then takes on the formula that used to be originally in row 8.

Is there something in the current code that's causing the formula in LeftSubject!F8:NZ400 to lose reference like that ?

It's not happening to the formulae I have in LeftSubject!B8:E400. They seem to be unaffected.

Kind regards,

Chris

 

[Peter_SSs]

I think this is the first we have heard of formulas (or anything) to the right of column E in LeftSubject.

Try making this cahnge and see how it goes.

<del>If Not Found Is Nothing Then Found.Resize(, 5).Delete Shift:=xlUp</del>
If Not Found Is Nothing Then Found.Offset(1).Resize(400, 5).Copy Destination:=Found

 

[palaeontology]

That did the trick ... thankyou, again, so much Peter.

Very kindest regards,

Chris

 

[Peter_SSs]

That did the trick ...

Good news!