Const WsPwg = "kolektor"     ' Пароль листов и книги
Const PwdRange = "A3:K999999"   ' Список контролируемых диапазонов ячеек
Const ПопытокМакс = 99999999       ' Кол. попыток ввода пароля до блокировки

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  УстановитьЗащиту
End Sub

' Событие загрузки книги
Private Sub Workbook_Open()
  УстановитьЗащиту
  ' После ввода перемещаться вправо. Закомментировать строчку ниже, если такое перемещение не требуется
  Application.MoveAfterReturnDirection = xlToRight
End Sub

Private Sub Workbook_Deactivate()
  Application.MoveAfterReturnDirection = xlDown
End Sub

' Выход: Восстановление перемещения вниз (обычно используется по умолчанию)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Application.MoveAfterReturnDirection = xlDown
End Sub


'  ' Событие изменения книги - отключено для версии v03-02
'  Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'    Dim x As Range
'    On Error Resume Next
'    ' Если изменения были не в контролируемом диапазоне, то выйти
'    Set x = Application.Intersect(Target, Range(PwdRange))
'    If x Is Nothing Then Exit Sub
'    ' Если было удаление ячейки, то выйти (удаление до первого ввода разрешено)
'    If Len(x(1, 1)) = 0 Then Exit Sub
'    ' Установить защиту ячейки
'    x.Locked = True
'    ' Изменить цвет фона
'    x.Interior.ColorIndex = 40
'    ' Включить защиту всех листов, если активный не защищен (антисклероз)
'    If Not Target.Parent.ProtectContents Then
'      Call УстановитьЗащиту
'    End If
'  End Sub

' Код кнопки 'Пароль' - ввод/снятие пароля на все листы и книгу
Private Sub Пароль()
  Dim x
  On Error Resume Next
  With ActiveSheet
    ' Вызвать диалог снятия пароля
    If .ProtectContents Then
      ' Обновить счетчик попыток снятия пароля
      [Попыток] = [Попыток] + 1
      ' Диалог снятия защиты листа
      If [Попыток] > ПопытокМакс Then
        ' Напугать
        MsgBox "Снятие пароля заблокировано", vbCritical
        Exit Sub
      End If
      Application.Dialogs(xlDialogProtectDocument).Show
    Else
      ' Пароль ранее был снят - предложить установить его
      x = MsgBox("Установить пароль?", vbYesNo + vbInformation)
      If x = vbYes Then
        Call УстановитьЗащиту
      Else
        ' После блокировки и ручного ввода пароля
        ' можно открыть все листы, если нажав кнопку,
        ' отказаться от предложени установки пароля
        Call СнятьЗащиту
      End If
      Exit Sub
    End If
    ' Неудачная попытка снятия пароля
    If .ProtectContents Then
      ' Предупредить
      MsgBox "Пароль не правильный", vbCritical
    Else
      Call СнятьЗащиту
    End If
  End With
End Sub

' Установить защиту всех листов
Private Sub УстановитьЗащиту()
  Dim Sh As Worksheet, x
  ' Отключить тормоза
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  ' Обработать все листы
  For Each Sh In Sheets
    ' Защитить лист паролем, разрешить работу макросов
    Sh.Protect Password:=WsPwg, UserInterfaceOnly:=True, _
               DrawingObjects:=True, Contents:=True, Scenarios:=True, _
               AllowInsertingColumns:=True, AllowInsertingRows:=True, _
               AllowDeletingColumns:=True, AllowDeletingRows:=True
    ' Запретить выбор защищенных ячеек
    Sh.EnableSelection = xlUnlockedCells
    ' Поставить защиту на все непустые ячейки
    Set x = Application.Intersect(Sh.Range(PwdRange), Sh.Cells.SpecialCells(xlCellTypeConstants))
    If Not x Is Nothing Then
      With x
        .Locked = True
        .Interior.ColorIndex = 40
      End With
    End If
  Next
  ' Скрыть служебный лист
  [Попыток] = 0
  [Попыток].Locked = True
  Скрытый.Visible = xlSheetVeryHidden
  ' Установить защиту книги
  ThisWorkbook.Protect Password:=WsPwg
  ' Включить тормоза
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  ' Сообщить об установке защиты
  MsgBox "Пароль установлен на все листы", vbOKOnly + vbInformation
End Sub

' Снять защиту всех листы
Private Sub СнятьЗащиту()
  Dim Sh As Worksheet
  ' Отключить тормоза
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  ' Обработать все листы
  For Each Sh In Sheets
    Sh.Unprotect Password:=WsPwg
    If Sh.Name <> Скрытый.Name Then
      Sh.Range(PwdRange).Interior.ColorIndex = 0
      Sh.Range(PwdRange).Locked = False
    End If
  Next
  ' Снять защиту книги
  ThisWorkbook.Unprotect Password:=WsPwg
  ' Открыть служебный лист
  Скрытый.Visible = xlSheetVisible
  ' Включить тормоза
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  ' Сообщить о снятии защиты
  MsgBox "Все листы разблокированы", vbOKOnly + vbInformation
End Sub