Excel schreibgeschützt - teilweise aber nur

Option Explicit

'<<<< A N P A S S E N  xxx >>>>
Private Const c_PW_BLATT = Blattschutzpasswort
Private Const c_BLATTNAME = Blatt1
Private Const c_ABZEILE = 2
Private Const c_PW_CHEF = HierKommtDerChef
'<<<< A N P A S S E N   E N D E>>>>

Private Type MyBenutzer_struct
  strBenutzerName As String
  lSpalte         As Long
End Type

Private fB() As MyBenutzer_struct, fBCnt As Long

'***************************************************************************
Private Function InitFeldUserRights(fB() As MyBenutzer_struct, fBCnt As Long)
  
  fBCnt = 0: ReDim fB(1 To 1)
  
'<<<< A N P A S S E N yyy >>>>
'Benutzername und Spalte

  fBCnt = fBCnt + 1
  ReDim Preserve fB(1 To fBCnt)
  With fB(fBCnt)
    .strBenutzerName = BenutzernameSpalte1: .lSpalte = 1
  End With
  
  fBCnt = fBCnt + 1
  ReDim Preserve fB(1 To fBCnt)
  With fB(fBCnt)
    .strBenutzerName = BenutzernameSpalte2: .lSpalte = 2
  End With
  
  fBCnt = fBCnt + 1
  ReDim Preserve fB(1 To fBCnt)
  With fB(fBCnt)
    .strBenutzerName = BenutzernameSpalte3: .lSpalte = 3
  End With
'<<<< A N P A S S E N   E N D E>>>>
  
End Function

'****************************************************************************
Function BlattSetzen() As Worksheet
  
  On Error Resume Next
  Set BlattSetzen = ThisWorkbook.Worksheets(c_BLATTNAME)
  If BlattSetzen Is Nothing Then
    MsgBox (Der in der Konstanten c_BLATTNAME definierte Blattname existiert nicht.)
  End If
  On Error GoTo 0
End Function

'****************************************************************************
Sub FuerBenutzerEntsperren()
  
  Dim ws As Worksheet
  Dim sBenutzer As String
  Dim x As Long, lRow As Long, lCol As Long
  
  Set ws = BlattSetzen
  If ws Is Nothing Then Exit Sub
  
  sBenutzer = Application.UserName
  Call InitFeldUserRights(fB(), fBCnt)
  
  For x = 1 To fBCnt
    If sBenutzer = fB(x).strBenutzerName Then
      lCol = fB(x).lSpalte
     ->letzte benutzte Zeile in Spalte suchen
      lRow = ws.Cells(ws.Rows.Count, lCol).End(xlUp).Row
     ->Blatt entsperren
      ws.Unprotect Password:=c_PW_BLATT
     ->alle Zellen als locked setzen
      ws.Cells.Locked = True
     ->ab der letzten beschriebenen Zeile die nächsten 100 Zellen unlocked
      ws.Range(ws.Cells(lRow + 1, lCol), ws.Cells(lRow + 100, lCol)).Locked = False
     ->Blatt sperren
      ws.Protect Password:=c_PW_BLATT
      ws.Parent.Save
      Exit For
    End If
  Next
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'****************************************************************************
Sub KomplettSperren()
  
  Dim ws As Worksheet
  
  Set ws = BlattSetzen
  If ws Is Nothing Then Exit Sub

 ->Blatt entsperren
  ws.Unprotect Password:=c_PW_BLATT
 ->alle Zellen als locked setzen
  ws.Cells.Locked = True
 ->Blatt sperren
  ws.Protect Password:=c_PW_BLATT
 ->speichern
  ws.Parent.Save
  
AUFRAEUMEN:
  Set ws = Nothing
End Sub

'****************************************************************************
Sub HierKommtDerChef()

  Dim ws As Worksheet
  Dim sPW As String
  sPW = InputBox( _
          Bitte geben Sie das Passwort ein, _
          Eingabe Entsperr-Passwort, _
          )
  
  If sPW = c_PW_CHEF Then
    Set ws = BlattSetzen
    If ws Is Nothing Then Exit Sub
   ->Blattschutz aufheben
    ws.Unprotect Password:=c_PW_BLATT
    Set ws = Nothing
  Else
    MsgBox falsches PW
  End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Call KomplettSperren
End Sub

Private Sub Workbook_Open()
  Call FuerBenutzerEntsperren
End Sub