Dim ws As Worksheet
Dim password As String
Dim protectedSheets As Collection
Dim protectedWithPasswordSheets As Collection
Dim newWorkbook As Workbook
Dim newSheet As Worksheet
Dim i As Integer
Set protectedSheets = New Collection
Set protectedWithPasswordSheets = New Collection
password = "1"
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
ws.Unprotect password:=password
If Err.Number <> 0 Then
If Err.Number <> 0 Then
protectedSheets.Add ws.Name
protectedWithPasswordSheets.Add ws.Name
Err.Clear
Else
protectedSheets.Add ws.Name
End If
Else
protectedSheets.Add ws.Name
End If
On Error GoTo 0
Next ws
Set newWorkbook = Workbooks.Add
Set newSheet = newWorkbook.Sheets(1)
newSheet.Name = "Geschützte Blätter"
newSheet.Cells(1, 1).Value = "Geschützte Blätter"
newSheet.Cells(1, 2).Value = "Mit Passwort"
For i = 1 To protectedSheets.Count
newSheet.Cells(i + 1, 1).Value = protectedSheets(i)
If Contains(protectedWithPasswordSheets, protectedSheets(i)) Then
newSheet.Cells(i + 1, 2).Value = "Ja"
Else
newSheet.Cells(i + 1, 2).Value = "Nein"
End If
Next i
MsgBox "Blattschutz für alle Blätter aufgehoben. Geschützte Blätter wurden aufgelistet."
End Sub
Function Contains(col As Collection, item As Variant) As Boolean
Dim i As Variant
For Each i In col
If i = item Then
Contains = True
Exit Function
End If
Next i
Contains = False
End Function
Hier noch verbessert. Es hebt bei allen Blättern den Blattschutz auf und listet, wenn es ein Blatt ist ohne bekanntes Passwort in einer neuen Tabelle auf.