Makros - Arbeitsblätter schützen mit zusätzlichen Optionen

Question

Guten Morgen,

ich würde gerne in etlichen Excel 2010 - Arbeitsmappen jeweils alle Arbeitsblätter gleichzeitig mit einem Makro schützen und den Schutz auf Wunsch mit einem zweiten Makro wieder aufheben.

Weiß zufällig jemand eine Lösung, die alle folgenden Optionen erfüllt (diese erscheinen in dieser Reihenfolge ja auch in dem Fenster, wenn man ein einzelnes Blatt schützen will)?:

- Arbeitsblatt und Inhalt gesperrter Zellen schützen
- Kennwort zum Aufheben des Blattschutzes: Am besten wäre, wenn ich das Passwort eingeben kann, alternativ ohne Passworteingabe und direkt mit dem Passwort „test“
- Gesperrte Zellen auswählen
- Nicht gesperrte Zellen auswählen
- Zellen formatieren
- Hyperlinks einfügen
- Objekte bearbeiten
- nicht sehr wichtig, aber praktisch wäre, wenn nach Ausführen des Makros wieder das aktuelle Arbeitsblatt erscheint

Vielen Dank für eure Mühe, es wäre eine große Hilfe für mich!
Ich bin leider ein VBA Laie, aber zumindest fand ich im Internet einige Vorschläge :-)
Ich weiß leider nicht, wie ich meine gewünschten Optionen hinzufüge:

BEFEHL FÜR DIE OPTION „OBJEKTE BEARBEITEN“:
DrawingObjects:=False


BEFEHL FÜR DIE OPTION, DASS DANACH WIEDER DAS AKTUELLE ARBEITSBLATT ERSCHEINT:
irgendwann zu Beginn: Set Blatt = ActiveSheet
irgendwann am Ende: Blatt.Select


VORSCHLAG FÜR DAS MAKRO MIT PASSWORTEINGABE
- ZUM SCHÜTZEN:
Option Explicit

Sub Schutz()
Dim i As Long
Dim p1 As String
Dim p2 As String
p1 = InputBox("Bitte Passwort eingeben!", "Passworteingabe")
p2 = InputBox("Bitte Passwort wiederholen!", "Passworteingabe")

If p1 = "" Or p2 = "" Then
MsgBox "Eingaben waren nicht korrekt!" & vbLf & vbLf & "Kein Blattschutz!"
Exit Sub
End If

If p1 <> p2 Then
MsgBox "Eingaben waren nicht korrekt!" & vbLf & vbLf & "Kein Blattschutz!"
Exit Sub
End If

For i = 1 To Sheets.Count
Sheets(i).Protect p1
Next i
MsgBox "alle Blätter wurden geschützt"

- SCHUTZ AUFHEBEN:
Sub Aufheben()
Dim i As Long
Dim p1 As String
Dim p2 As String
p1 = InputBox("Bitte Passwort eingeben!", "Passworteingabe")
If p1 = "" Then
MsgBox "Kein Passwort eingegeben!" & vbLf & vbLf & "Blattschutz wird nicht nicht aufgehoben!"
Exit Sub
End If
On Error GoTo fehler
For i = 1 To Sheets.Count
Sheets(i).Unprotect p1
Next i
MsgBox "alle Blätter wurden entsperrt"

fehler:
If Err Then MsgBox "Falsches Passwort"
End Sub

Answer 1

Hallo,

manchmal hilft auch der Makrorekorder weiter ;-).

Versuch es mal so:

Sub Schutz()
Dim i As Long
Dim p1 As String
Dim p2 As String

p1 = InputBox("Bitte Passwort eingeben!", "Passworteingabe")
p2 = InputBox("Bitte Passwort wiederholen!", "Passworteingabe")

If p1 = "" Or p2 = "" Or p1 <> p2 Then
MsgBox "Eingaben waren nicht korrekt!" & vbLf & vbLf & "Kein Blattschutz!", 16, "Passwort fehlerhaft"
Exit Sub
End If

For i = 1 To ThisWorkbook.Worksheets.Count
With Worksheets(i)
.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingCells:=True, AllowInsertingHyperlinks:=True
.Protect p1
End With
Next i

MsgBox "alle Blätter wurden geschützt", 64, "Blattschutz"

End Sub

Sub Aufheben()
Dim i As Long
Dim p1 As String

p1 = InputBox("Bitte Passwort eingeben!", "Passworteingabe")
If p1 = "" Then
MsgBox "Kein Passwort eingegeben!" & vbLf & vbLf & "Blattschutz wird nicht nicht aufgehoben!", 16, "Ungültiges Passwort"
Exit Sub
End If
On Error GoTo fehler
For i = 1 To ThisWorkbook.Worksheets.Count
Worksheets(i).Unprotect p1
Next i

MsgBox "alle Blätter wurden entsperrt", 64, "Blattschutz"

fehler:
If Err Then MsgBox "Falsches Passwort", 16, "Fehler"
End Sub

Ich gehe mal davon aus, dass in deiner Arbeitsmappe nur Tabellenblätter vorhanden und keine Diagramme die geschützt werden sollen. Daher habe ich Sheets durch Worksheets ersetzt.

Das aktuelle Blatt brauchst du nicht wieder auszuwählen, da es ja nicht "verlassen" wird. Es ist nach Ausführung der Makros immer noch aktiv.

Gruß

M.O.

Answer 2

Danke für die schnelle Antwort!

es hat super funktioniert bis auf die Optionen
- Zellen formatieren
- Hyperlinks einfügen
- Objekte bearbeiten

Nichts davon ist möglich. Woran könnte das liegen?

Answer 3

Hallo,

Fehler von mir :-(. Versuch es mal so mit dem Schützen-Makro:

Sub Schutz()
Dim i As Long
Dim p1 As String
Dim p2 As String

p1 = InputBox("Bitte Passwort eingeben!", "Passworteingabe")
p2 = InputBox("Bitte Passwort wiederholen!", "Passworteingabe")

If p1 = "" Or p2 = "" Or p1 <> p2 Then
MsgBox "Eingaben waren nicht korrekt!" & vbLf & vbLf & "Kein Blattschutz!", 16, "Passwort fehlerhaft"
Exit Sub
End If

For i = 1 To ThisWorkbook.Worksheets.Count
Worksheets(i).Protect Password:=p1, DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingCells:=True, AllowInsertingHyperlinks:=True
Next i

MsgBox "alle Blätter wurden geschützt", 64, "Blattschutz"

End Sub

Gruß

M.O.

Answer 4

Hat perfekt geklappt, vielen Dank!!!