Registriert seit: 10.12.2018
Version(en): 2016
Hallo zusammen,
hoffentlich haben alle Weihnachten gut überstanden und sind gut erholt.
Seit der weihnachtlichen Ruhe brühte ich vor einem Problem
welches ich noch nicht so richtig gelöst bekomme.
Wenn meine Exceltabelle gespeichert wird, werden alle
beschrieben Zellen gesperrt. Das funktioniert mit dem
unten stehenden Script ganz gut. Nun muss ich noch ein paar
Ausnahmen definieren, wenn in einer Zelle einer Spalte der Wert "a"
auftaucht darf diese Zelle nicht gesperrt sein.
Hat jemand eine Idee wie ich das Script anpassen muss?
Im Detail betrifft dies die Spalte "L" für die Buchstaben "a"; "s",
und die Spalte "W" für den Buchstaben "s"
Vielen Dank!
Code in "Diese Arbeitsmappe"
Code: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
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
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, Password:="record"
End With
End Sub
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo
probier bitte mal diesen geaenderten Code aus. Mit Zellen farblich markieren habe ich ihn getestet.
Die Such und Find Mehode ist für korrektes "a" + "s" suchen auf Kleinbuchstaben = True eingestellt,
Ein frohes und gesundes neues Jahr wünsche ich allen ...
mfg Gast 123
Code: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Spa As String, Wert As String 'neu eingefügt
Dim rFind As Range, Adr1 As String
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
'Einzel-Zellen wieder entsperren über Such Unterprogramm (GoSub)
Spa = "L": Wert = "a"
Zahl = Application.WorksheetFunction.CountIf(Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
Spa = "L": Wert = "s"
Zahl = Application.WorksheetFunction.CountIf(Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
Spa = "W": Wert = "s"
Zahl = Application.WorksheetFunction.CountIf(Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
'normales Protext Programm wie vorher
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, Password:="record"
End With
Exit Sub
such: 'Suchlauf als Unterprogramm mit Return
Set rFind = Columns(Spa).Find(What:=Wert, After:=Range(Spa & "1"), LookIn:= _
xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
If Not rFind Is Nothing Then
Adr1 = rFind.Address
Do 'alle Zellen entsperren
rFind.Locked = False
Set rFind = Columns(Spa).FindNext(After:=rFind)
Loop Until rFind.Address = Adr1
End If
Return
End Sub
Registriert seit: 10.12.2018
Version(en): 2016
Hi,
Danke für deine Antwort.
Zahl musste noch definiert werden, hab ich als String gesetzt;
beim Speichern kommt dann aber Laufzeitfehler 91- "Objektvariable oder With-Blockvariable nicht festgelegt"
Im Debugmodus geht er dann in die Zeile "Loop Until rFind.Address = Adr1"
im Unterprogramm.
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo
hier noch mal ein korrigierter Code. Die With Klammer muss ganz nach unten hinter Return, weil sich auch diese Spalten auf With beziehen. An einigen Stellen hatte ich leider auch den Punkt für With vergessen. Das merkt Excel natürlich und meckert. Jetzt sollte es klappen.
Zahl bitte nicht als String definieren, von der Logik her ist es ja eine Zahl. Ich habe zur Vorsicht Long genommen.
mfg Gast 123
Code: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Spa As String, Wert As String 'neu eingefügt
Dim rFind As Range, Adr1 As String
Dim wsTab As Worksheet, Zahl As Long
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
'Einzel-Zellen wieder entsperren über Such Unterprogramm (GoSub)
Spa = "L": Wert = "a"
Zahl = Application.WorksheetFunction.CountIf(.Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
Spa = "L": Wert = "s"
Zahl = Application.WorksheetFunction.CountIf(.Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
Spa = "W": Wert = "s"
Zahl = Application.WorksheetFunction.CountIf(.Columns(Spa), Wert)
If Zahl > 0 Then GoSub such
'normales Protext Programm wie vorher
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, Password:="record"
'End With
Exit Sub
such: 'Suchlauf als Unterprogramm mit Return
Set rFind = .Columns(Spa).Find(What:=Wert, After:=.Range(Spa & "1"), LookIn:= _
xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
If Not rFind Is Nothing Then
Adr1 = rFind.Address
Do 'alle Zellen entsperren
rFind.Locked = False
Set rFind = .Columns(Spa).FindNext(After:=rFind)
Loop Until rFind.Address = Adr1
End If
Return
End With
End Sub
Registriert seit: 10.12.2018
Version(en): 2016
27.12.2018, 20:39
(Dieser Beitrag wurde zuletzt bearbeitet: 27.12.2018, 20:39 von Matix.)
Danke für die Hilfe,
das funktioniert jetzt
Registriert seit: 16.08.2017
Version(en): 2007 / 2010 / Web
Hi
würde ich so versuchen.
Code: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rngB As Range
Dim i As Long
Dim z As Variant
On Error Resume Next
With Sheets("Korrekturen")
.Unprotect Password:="record"
.Range("A:X").Locked = True
.Range("A:X").SpecialCells(xlCellTypeBlanks).Locked = False
For i = 12 To 23 Step 11
Set rngB = .Columns(i).SpecialCells(xlCellTypeConstants)
For Each z In rngB
If z.Value = "s" Then z.Locked = False
If z.Value = "a" And i = 12 Then z.Locked = False
Next z
Next i
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, Password:="record"
End With
End Sub
Gruß Elex
Registriert seit: 10.12.2018
Version(en): 2016
Ich musste dennoch ein "On Errore Resume Next" einbauen,
sonst kam immer dieser Laufzeitfehler
Code schaut jetzt so aus:
Code: such: 'Suchlauf als Unterprogramm mit Return
Set rFind = .Columns(Spa).Find(What:=Wert, After:=.Range(Spa & "1"), LookIn:= _
xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
On Error Resume Next 'sonst Laugzeitfehler und Markierung bei Loop...
If Not rFind Is Nothing Then
Adr1 = rFind.Address
Do 'alle Zellen entsperren
rFind.Locked = False
Set rFind = .Columns(Spa).FindNext(After:=rFind)
Loop Until rFind.Address = Adr1
End If
Return
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo
der Code sollte Ohne Resume Next laufen. Ist denn hinter Return das "End With" als letzter Befehl??? Direkt vor End Sub!!
Wenn das fehlt ist klar warum Excel einen Laufzeitfehler hat! Vor Exit Sub hatte ich es deaktiviert, auf "grün" als Kommentar gesetzt.
mfg Gast 123
Registriert seit: 10.12.2018
Version(en): 2016
Ich atte den Code eins zu eins kopiert,
und er hat Laufzeitfehler angezeigt und im Debugmodus
die zeile mit Loop... gekennzeichnet
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo
da komme ich jetzt echt ins Grübeln, habe den Code bei mir noch einmal getestet. Auf meinem PC laeuft er fehlerfrei.
meine Bitte: den unteren Teil bitte zum Adressen Test wechseln und sich per MsgBox die Adressen anschauen, ob sie real vorhanden sind???
Wenn es sie gibt kann ich nur bitten das "Korrekturen" Blatt zu kopieren, mit anonymen Daten, und als Beispiel hochzuladen.
Aus der Ferne, ohne die Datei selbst zu sehen, ist Fehlersuche schwierig. Die Adressen bitte zuerst selbst prüfen.
mfg Gast 123
Code: such: 'Suchlauf als Unterprogramm mit Return
Set rFind = .Columns(Spa).Find(What:=Wert, After:=.Range(Spa & "1"), LookIn:= _
xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
If Not rFind Is Nothing Then
Adr1 = rFind.Address
MsgBox Adr1 & " " & rFind.Value
Do 'alle Zellen entsperren
rFind.Locked = False
Set rFind = .Columns(Spa).FindNext(After:=rFind)
MsgBox rFind.Address & " " & rFind.Value
Exit Sub '## nur zum Adressen Test!!
Loop Until rFind.Address = Adr1
End If
Return
End With
End Sub
|