список выбора нескольких вариантов Excel VBA не работает на листе защиты паролем

Question

Есть какие-нибудь мысли о том, как изменить это значение, чтобы разрешить запуск множественного выбора на защищенном паролем листе без необходимости ввода пароля?

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Oldvalue As String
Dim Newvalue As String
Dim num As Integer

On Error GoTo Exitsub

If Target.Address = "$H$29" Or Target.Address = "$H$33" Or Target.Address = "$H$37" Or Target.Address = "$H$42" Or Target.Address = "$H$58" Or Target.Address = "$H$59" Or Target.Address = "$H$60" Or Target.Address = "$H$63" Or Target.Address = "$H$65" Or Target.Address = "$M$29" Or Target.Address = "$M$33" Or Target.Address = "$M$37" Or Target.Address = "$M$42" Or Target.Address = "$M$58" Or Target.Address = "$M$59" Or Target.Address = "$M$60" Or Target.Address = "$M$63" Or Target.Address = "$M$65" 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
            num = InStr(Oldvalue, Newvalue)
            If num = 0 Then ' If the element selected isnt already on the selected list
              Target.Value = Oldvalue & ", " & Newvalue
            ElseIf num = 1 Then ' If the element is the first on the list
              If Len(Oldvalue) = Len(Newvalue) Then ' If the element is the only element selected
                Target.Value = Replace(Oldvalue, Newvalue, "")
              Else                                  ' If the element is not the only element selected
                Target.Value = Replace(Oldvalue, Newvalue & ", ", "")
              End If
            ElseIf num > 1 Then  ' If the element is not the first
              Target.Value = Replace(Oldvalue, ", " & Newvalue, "")
            End If
        End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

Answer 1

Вариант 1 снимите защиту листа, запустите свой код, а затем снова защитите его с помощью VBA (но это может быть небезопасно, когда макрос остановлен в середине)

Вариант 2 защитите лист с помощью этого кода

ActiveSheet.Protect "password", UserInterfaceOnly:=True

таким образом лист защищен только от изменений пользователя, а не от изменений макроса.

Answer 2

SpecialCells(xlCellTypeAllValidation) выдает ошибку на защищенном листе

Это будет работать на защищенном листе:

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SEP As String = ","
    Dim c As Range, NewValue, OldValue, arr, v, lst, removed As Boolean

    On Error GoTo Exitsub

    If Target.CountLarge > 1 Then Exit Sub '<< only handling single-cell changes

    'is the changed cell in our monitored range?
    Set c = Application.Intersect(Target, Me.Range("B5,B7,B9,B11")) ' for example

    If Not c Is Nothing Then
        If Len(c.Value) > 0 And Not c.Validation Is Nothing Then

            Application.EnableEvents = False
            NewValue = c.Value
            Application.Undo
            OldValue = c.Value

            If OldValue = "" Then
                c.Value = NewValue
            Else
                arr = Split(OldValue, SEP)
                'loop over previous list, removing newvalue if found
                For Each v In arr
                    If v = NewValue Then
                        removed = True
                    Else
                        lst = lst & IIf(lst = "", "", SEP) & v
                    End If
                Next v
                'add the new value if we didn't just remove it
                If Not removed Then lst = lst & IIf(lst = "", "", SEP) & NewValue
                c.Value = lst
            End If
        End If    'has validation and non-empty
    End If        'handling this cell

Exitsub:
    If Err.Number <> 0 Then MsgBox Err.Description
    Application.EnableEvents = True
End Sub