Option
Explicit
Sub
Test_BeforeSave()
Dim
wsTab
As
Worksheet
Dim
rngWerte
As
Range
Dim
rngFormeln
As
Range
Set
wsTab = Worksheets(
"Korrekturen"
)
On
Error
Resume
Next
With
wsTab
If
.ProtectContents =
True
Then
.Unprotect Password:=
"record"
With
.Range(
"A:X"
)
.Locked =
False
On
Error
Resume
Next
Set
rngWerte = .SpecialCells(xlCellTypeConstants)
Set
rngFormeln = .SpecialCells(xlCellTypeFormulas)
On
Error
GoTo
0
End
With
If
Not
rngWerte
Is
Nothing
Then
rngWerte.Locked =
True
If
Not
rngFormeln
Is
Nothing
Then
rngFormeln.Locked =
True
Ausnahmen wsTab, 12,
"a"
, xlWhole
Ausnahmen wsTab, 23,
"s"
, xlWhole
Ausnahmen wsTab, 12,
"s"
, xlPart
.Protect DrawingObjects:=
True
, Contents:=
True
, Scenarios:=
True
_
, AllowSorting:=
True
, AllowFiltering:=
True
, Password:=
"record"
End
With
End
Sub
Private
Sub
Ausnahmen(Blatt
As
Worksheet, Spalte
As
Long
, Suche
As
String
, Wie
As
Long
)
Dim
c
As
Range, fa
As
String
With
Blatt.Columns(Spalte)
Set
c = .Find(Suche, LookIn:=xlValues, LookAt:=Wie)
If
Not
c
Is
Nothing
Then
fa = c.Address
Do
c.Locked =
False
Set
c = .FindNext(c)
Loop
While
Not
c
Is
Nothing
And
c.Address <> fa
End
If
End
With
End
Sub