AW: VBA Schutz von Zellen mit Formeln
23.05.2023 11:33:49
Joschi Witchcraft
Guten Morgen, MCO
Nach einem Hinweis im Thread hatte ich den Code wie folgt angepasst:
With ActiveSheet
If .ProtectContents Then .Unprotect
Cells.Locked = False
.UsedRange.SpecialCells(xlCellTypeFormulas, Type:=XlCellType.xlCellTypeFormulas).Select
.UsedRange.SpecialCells(xlCellTypeFormulas, Type:=XlCellType.xlCellTypeFormulas).Locked = True
.Protect
End With
Die Zeile mit "xlCellTypeBlanks" habe ich bewusst entfernt, weil ich sonst in den vorgesehenen Zellen keine Werte hätte überschreiben dürfen.
Mit diesem Code ist es allerdings nicht möglich, neue Zeilen einzufügen. Deshalb habe ich nach einer anderen Lösung gesucht, und mit "UNDO" experimentiert.
Ich habe inzwischen meine Lösung ohne Blattschutz und Locked gefunden. Hier mein Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColsNew As Integer
Dim ColsOld As Integer
Dim ColTarg As Integer
Dim RowsNew As Integer
Dim RowsOld As Integer
Dim RowTarg As Integer
RowTarg = Target.Row
ColTarg = Target.Column
RowsNew = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
ColsNew = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Debug.Print "vor Undo " & Cells(RowTarg, ColTarg).Value
If Cells(RowTarg, ColTarg).HasFormula Then Debug.Print "Formel: " & Cells(RowTarg, ColTarg).Formula
Application.EnableEvents = False
Application.Undo ' alten Zustand herstellen
RowsOld = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
ColsOld = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Debug.Print RowsNew & " " & RowsOld
Debug.Print ColsNew & " " & ColsOld
Debug.Print "Undo 1 " & Cells(RowTarg, ColTarg).Value
If ColsNew > ColsOld Then
Debug.Print "Spalte hinzugefügt oder entfernt"
If RowTarg > 6 Then
Application.Undo ' insert ist zulässig
End If
GoTo SkipUndo
End If
If RowsNew > RowsOld Then
Debug.Print "Zeile hinzugefügt oder entfernt"
Application.Undo ' insert ist zulässig
GoTo SkipUndo
End If
If Cells(RowTarg, ColTarg).HasFormula Then
Debug.Print "Zelle mit Formel"
Debug.Print "Formel: " & Cells(RowTarg, ColTarg).Formula
GoTo SkipUndo ' keine Ände
End If
Application.Undo
Debug.Print "Undo 2 " & Cells(RowTarg, ColTarg).Value
SkipUndo:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim LastRow As Integer
LastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Rows(Target.Row).Copy
Stop
Rows(LastRow + 1).Insert
Debug.Print "kopiert"
Cancel = True
End Sub
Natürlich muss dieser Code noch an die Gegebenheiten der aktuellen Tabelle angepasst werden. Die Debugs dienen nur Testzwecken
Gruß Joschi.