Excel VBA gefüllte Zellen sperren aber mit Ausnahmen

[Matix]

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

[Gast 123]

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

[Matix]

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.

[Gast 123]

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

[Matix]

Danke für die Hilfe,
das funktioniert jetzt

[Elex]

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

[Matix]

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

[Gast 123]

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

[Matix]

Ich atte den Code eins zu eins kopiert,
und er hat Laufzeitfehler angezeigt und im Debugmodus
die zeile mit Loop... gekennzeichnet

[Gast 123]

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