Unprotect - Protect aller Tabellen gleichzeitig
18.10.2004 12:40:20
Klaus
meine Arbeitsmappe besteht aus insgesamt 6 Tabellen (PK, POK, PHK A11, ...).
Die dort eingetragenen Kollegen gehören verschiedenen Abteilungen an.
Über eine "InputBox" kann eine bestimmte Abteilung ausgewählt und eine entsprechend gefilterte neue Mappe erstellt werden.
Das Problem ist jedoch, dass bestimmte Spalten der einzelnen Tabellen geschützt sind.
Kann mir bitte jemand auf die Sprünge helfen, wie ich beim Ausführen des nachstehenden Codes den Blattschutz kurzfristig aufheben und danach wieder aktivieren kann.
Das hier funktioniert leider nicht:
Sheets(Array("PK", "POK", "PHK A11", "PHK A12", "EPHK", "POK §14")).Unprotect Password:="......."
Vielen Dank für angedachte Hilfe.
Sub Export3()
Dim WS
Dim i, Abt
Dim Spalte As Byte
'Hier sind auf jeden Fall Anpassungen notwendig
Spalte = 5 'in dieser Spalte ist die Abteilung
'Abteilung erfragen
Abt = InputBox("Für welche Dienststelle soll eine neue Mappe erstellt werden? Bitte genaue Schreibweise beachten!")
If Abt = "" Then Exit Sub
Sheets(Array("PK", "POK", "PHK A11", "PHK A12", "EPHK", "POK §14")).Unprotect Password:="......."
Sheets(Array("PK", "POK", "PHK A11", "PHK A12", "EPHK", "POK §14")).Copy
For Each WS In ActiveWorkbook.Worksheets
'Zeilen mit falscher Abteilung Inhalt löschen
For i = WS.Cells(Rows.Count, 1).End(xlUp).Row To 16 Step -1
If WS.Cells(i, Spalte) <> Abt Then WS.Rows(i) = ""
Next i
For Each sh In WS.Shapes
sh.Delete
Next sh
Next WS
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-6
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("POK").Select
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-5
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("PHK A11").Select
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-4
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("PHK A12").Select
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-4
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("EPHK").Select
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-4
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("POK §14").Select
Range("B16:W215").Select
Selection.Sort Key1:=Range("C16:C215"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWindow.SmallScroll ToRight:=-5
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets(Array("PK", "POK", "PHK A11", "PHK A12", "EPHK", "POK §14")).Select
Sheets("PK").Activate
Range("A16:A215").Select
Selection.ClearContents
ActiveWindow.ScrollRow = 16
Range("A16").Select
ActiveCell.FormulaR1C1 = "1"
Range("A17").Select
ActiveCell.FormulaR1C1 = "2"
Range("A16:A17").Select
Selection.AutoFill Destination:=Range("A16:A215"), Type:=xlFillDefault
Range("A16:A215").Select
ActiveWindow.ScrollRow = 16
Range("A16").Select
Sheets("PK").Select
Sheets(Array("PK", "POK", "PHK A11", "PHK A12", "EPHK", "POK §14")).Protect Password:="......"
End Sub