Blattschutz über alle Excel-Dateien
11.03.2021 10:50:57
Björn
ich habe das Excel 2019.
Ich möchte mehrere Dateien in einem Ordner automatisiert mit Blattschutz versehen und wieder aufheben können. Das Passwort ist immer gleich.
Das Thema gab es schonmal hier:
https://www.herber.de/forum/archiv/1268to1272/1270826_Blattschutz_ueber_alle_ExcelDateien_eines_Ordners.html
Ich habe diese Lösung genommen:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub schutzAn()
protectAllSheets "E:\Forum", "DeinPasswort", True
End Sub
Sub schutzAus()
protectAllSheets "E:\Forum", "DeinPasswort", False
End Sub
Sub protectAllSheets(Directory As String, Password As String, Protection As Boolean)
Dim objWB As Workbook, objSH As Worksheet
Dim strFile As String, strDir As String
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
strDir = IIf(Right(Directory, 1) = "\", Directory, Directory & "\")
strFile = Dir(strDir & "*.xls*", vbNormal)
Do While strFile ""
If strDir & strFile ThisWorkbook.FullName Then
Set objWB = Workbooks.Open(strDir & strFile, UpdateLinks:=False)
For Each objSH In objWB.Worksheets
If Protection Then
objSH.Protect Password
Else
objSH.Unprotect Password
End If
Next
objWB.Close True
End If
strFile = Dir
Loop
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'protectAllSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objWB = Nothing
Set objSH = Nothing
End Sub
Ich habe es getestet. Den Blattschutz vergeben hat super funktioniert. Den Blattschutz aufheben nicht. Er öffnet die erste Datei, hebt den Blattschutz auf und bringt dann eine Fehlermeldung und bricht ab.
VBA - Fehler in Modul - Modul 1
Fehler in Prozedur: 'protectAllSheets'
________________________________
Fehlernummer: 1004
Beschreibung: Das eingegebene Kenntwort ist ungültig. Stellen Sie sicher, dass die FESTSTELLTASTE nicht aktiviert ist und dass SIe die korrekte Groß-Kleinschreibung verwenden.
OK
Natürlich habe ich das geprüft. Die erste Datei hat ja auch funktioniert.
Könnt ihr mir als Laien sagen was ich tun muss?
Danke.