Excel-Tabelle schützen vor zweite Bearbeitung

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Const cBLTNAME = Tabellexyz-> zu schützendes Blatt
  Const pw =  ->hier ggf. PW für Blattschutz eintragen
  
  Dim ws As Worksheet
  
  On Error Resume Next
  Set ws = ThisWorkbook.Worksheets(cBLTNAME)
  Err.Clear: On Error GoTo 0
  If ws Is Nothing Then
    MsgBox Blatt  & cBLTNAME &  nicht vorhanden.
    GoTo AUFRAEUMEN
  End If
  
 ->Schreibschutz des Blattes entfernen
  ws.Activate
  On Error Resume Next
  ActiveSheet.Unprotect Password:=pw
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->alle Zellen entsperren
  ws.Cells.Locked = False
  
 ->Speichern (dabei events abschalten)
 ->UsedRange sperren
  Application.EnableEvents = False
  ThisWorkbook.Save
 ->bei leerem Blatt nichts sperren
  If ws.UsedRange.Count > 1 Then ws.UsedRange.Locked = True
  ThisWorkbook.Save
  Application.EnableEvents = True
  
 ->Blattschutz setzen
  ActiveSheet.Protect Password:=pw
  
 ->Speicherung abbrechen, da schon alles gespeichert ist,
 ->wenn nicht Speichern unter ...
  If Not SaveAsUI Then Cancel = True
AUFRAEUMEN:
  Set ws = Nothing
End Sub

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  
 -><<<<<<<<<< A N P A S S E N >>>>>>>>>>>>>>>>>>>>>>
  Const cBLTNAME = Tabelle1-> zu schützendes Blatt
  Const pw =  ->hier ggf. PW für Blattschutz eintragen
  
 ->zu Schützender Bereich ab Zeile.../Spalte...
  Const cZ_ERSTEWERTEZEILE = 3
  Const cSP_ERSTEWERTESPALTE = 2
 -><<<<<<<<<< A N P A S S E N   E N D E >>>>>>>>>>>>
  
  Dim ws As Worksheet
  Dim r As Range, Zelle As Range, ersteAdresse As String
  Dim lRows As Long, lCols As Long
  
  On Error Resume Next
  Set ws = ThisWorkbook.Worksheets(cBLTNAME)
  Err.Clear: On Error GoTo 0
  If ws Is Nothing Then
    MsgBox Blatt  & cBLTNAME &  nicht vorhanden.
    GoTo AUFRAEUMEN
  End If
  
 ->Schreibschutz des Blattes entfernen
  ws.Activate
  On Error Resume Next
  ActiveSheet.Unprotect Password:=pw
  If Err.Number <> 0 Then
    MsgBox Blatt-Schutz konnte nicht entfernt werden.
    GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  
 ->Bereich der zu schützenden Zellen setzen
  lRows = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
  lCols = ws.UsedRange.Columns.Count + ws.UsedRange.Column - 1
  Set r = ws.Range( _
              ws.Cells(cZ_ERSTEWERTEZEILE, cSP_ERSTEWERTESPALTE), _
              ws.Cells(lRows, lCols))
  
 ->Zellen entsperren
  r.Locked = False
  
 ->alle nicht leeren Zellen (Werte, nicht Formeln) suchen und sperren
  With r
    Set Zelle = .Cells(1)
    Set Zelle = .Find(What:=*, _
                      After:=Zelle, _
                      LookIn:=xlValues, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False)
    If Not Zelle Is Nothing Then
      ersteAdresse = Zelle.Address
        Do
          Zelle.Locked = True
          Set Zelle = .FindNext(Zelle)
          If Zelle Is Nothing Then Exit Do
          If Zelle.Address = ersteAdresse Then Exit Do
        Loop
    End If
  End With
  
 ->Blattschutz setzen
  ActiveSheet.Protect Password:=pw
  
AUFRAEUMEN:
  Set ws = Nothing: Set r = Nothing: Set Zelle = Nothing
End Sub

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
  
 -><<<<<<<<<<<<< A N P A S S E N >>>>>>>>>>
  Const cENTSPERRPASSWORT = xyz
  Const pw =  ->hier ggf. PW für Blattschutz eintragen
 -><<<<<<<<<<<<< A N P A S S E N   E N D E >>>>>>>>>>
  
  Dim sPW As String
  
  If Target.Count = 1 Then
    If Target.Locked Then
      sPW = InputBox( _
            Bitte geben Sie das Paßwort zum entsperren der Zeile ein., _
            Zeile entsperren, )
      If sPW <> cENTSPERRPASSWORT Then
        If sPW <>  Then MsgBox Passwort falsch :-)
        Cancel = True
      Else
       ->Schreibschutz des Blattes entfernen
        On Error Resume Next
        Target.Parent.Unprotect Password:=pw
        If Err.Number <> 0 Then
          MsgBox Blatt-Schutz konnte nicht entfernt werden.
          Cancel = True
          Exit Sub
        End If
        On Error GoTo 0
        Target.EntireRow.Locked = False
        
       ->Blattschutz setzen
        Target.Parent.Protect Password:=pw
      End If
    End If
  End If
End Sub