Worksheet_Change模块防止工作表保护

Question

我在工作表中有一个Worksheet_Change模块，它允许我从下拉列表中选择多个，逗号分隔，不可重复的数字，显示在单个单元格中，例如$C$4将读取"00004,00006,00009";等。这是我从https://trumpexcel.com/select-multiple-items-drop-down-list-excel/#VBA-Code-to-allow-Multiple-Selections-in-a-Drop-down-List-without-repetition逐字复制的代码-我只更改了"目标"。细胞):

Private Sub Worksheet_Change(ByVal Target As Range)   
'Code by Sumit Bansal from https://trumpexcel.com   
'To allow multiple selections in a Drop Down List in Excel (without repetition)   
Dim Oldvalue As String  
Dim Newvalue As String  
Application.EnableEvents = False  
On Error GoTo Exitsub  
If Target.Address = "$K$9" Then                                                                
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then  
GoTo Exitsub  
Else:  
If Target.Value = "" Then GoTo Exitsub Else  
Application.EnableEvents = False  
Newvalue = Target.Value  
Application.Undo  
Oldvalue = Target.Value  
If Oldvalue = "" Then  
Target.Value = Newvalue  
Else  
If InStr(1, Oldvalue, Newvalue) = 0 Then  
Target.Value = Oldvalue & ", " & Newvalue  
End If  
Else:  
Target.Value = Oldvalue  
End If  
End If  
End If  
End If  
Application.EnableEvents = True  
Exitsub:   
Application.EnableEvents = True  
End Sub  

这个问题——我知道我不是第一个遇到这个问题的人，我看过其他几个解决方案，但似乎都不起作用——是我需要表被保护。但是当我保护它时，代码不再工作，我只能为每个单元格选择一个nr。

我试过关闭EnableEvents，然后添加"未保护"one_answers";protect"行在不同的地方，但这没有什么区别，就好像代码完全忽略了这些行，不管我把它们放在哪里。但是床单必须被保护起来。会有几个人来处理它，在其他单元中有很长很复杂的公式，我不能让他们搞砸。有什么建议吗?

Answer 1

EDIT: added "重新选择时删除项目">

这将在受保护的工作表上工作，因为它不使用SpecialCells:

Private Sub Worksheet_Change(ByVal Target As Range)
Const SEP As String = ", "
Dim Oldvalue As String, Newvalue As String, arr, m, v

'avoid nested If's by first figuring out if we need to do anything...
If Target.CountLarge > 1 Then Exit Sub           'single cell only
If Target.Address <> "$K$9" Then Exit Sub        'only checking K9
If Not HasListValidation(Target) Then Exit Sub   '...with a list validation
If Target.Value = "" Then Exit Sub               '...and a value

On Error GoTo Exitsub
Application.EnableEvents = False
Newvalue = Target.Value
If Len(Newvalue) = 0 Then Exit Sub 'user has cleared the cell...

Application.Undo
Oldvalue = Target.Value

Debug.Print Oldvalue, Newvalue

If Oldvalue <> "" Then
arr = Split(Oldvalue, SEP)
m = Application.Match(Newvalue, arr, 0)
If IsError(m) Then
Newvalue = Oldvalue & SEP & Newvalue
Else
arr(m - 1) = ""
Newvalue = ""
For Each v In arr
If Len(v) > 0 Then Newvalue = _
Newvalue & IIf(Len(Newvalue) > 0, SEP, "") & v
Next v
End If
End If
Target.Value = Newvalue
Exitsub:
If Err.Number <> 0 Then Debug.Print "Error", Err.Description
Application.EnableEvents = True
End Sub
'does a cell have a list validation?
Function HasListValidation(c As Range)
Dim vType
On Error Resume Next
vType = c.Validation.Type
On Error GoTo 0
HasListValidation = (vType = 3)
End Function