Suche Hilfe bei Tabelle
26.02.2006 12:45:44
Petra
ich habe folgendes Problem.Bei meiner Datei ist der Blattschutz ohne Eingabe eines Passwort gesetzt.
Aus gegebenen Anlass möchte ich nun ein Passwort setzen,( der Anlass weil mehrere Leute nacheinander mit der Tabelle arbeiten, und leider der Meinung sind warum auch immer mal ein Passwort vergeben zu müssen ).
Mit dem unten stehenden Code wird die Tab. gesichert was auch herforagend klappt.Nur wenn jemand ein PW. eingibt wird bei dem Versuch die Tab. zu sichern das PW. verlangt. Ich möchte dem Unfug nun ein Ende setzen.
Wie kann ich ein PW. setzen so das ein Sicherung ohne das nach dem PW. gefragt wird möglich ist ? Kann man das PW in den Code mit intigrieren ?, den der VBA Code ist mit einen PW. gesichert und ist nicht einsebar.
Über eine Hilfe würde ich mich sehr freuen.
Gruss Petra
Sub Blatt1Kopieren()
Dim strPath As String
Dim strName As String
Dim strWert As String
Dim shp As Shape
ActiveSheet.Unprotect
strPath = "D:\Eigene Dateien\Sicherung_xls\" 'Pfad
strName = ActiveSheet.Name 'Tabellenname
strWert = ActiveSheet.Range("A1") 'Dateiname - zusatz
Application.ScreenUpdating = False
ActiveSheet.Copy
With ActiveWorkbook
For Each shp In Sheets(1).Shapes 'Schaltflächen entfernen
shp.Delete
Next
.Sheets(1).Cells.Copy ' Formeln auf Copy entfernen
.Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule 'VBA Projecte entfernen
.DeleteLines 1, .CountOfLines
End With
.Sheets(1).Cells.Locked = True 'Zellen sperren
.Sheets(1).Protect "test" 'Blattschutz setzen - Passwort anpassen
.SaveAs strPath & strName & " " & Format(Date, "dd-mm-yy") & " " & _
strWert & ".xls"
MsgBox " Kopie von " & strName & " " & strWert & " wurde angelegt "
MsgBox " Das Blatt 1 wird nun gedruckt 1 Kopie"
.Close
End With
Application.ScreenUpdating = True
ActiveSheet.Protect
Sheets("Blatt1").Select
ActiveSheet.Unprotect
Application.ScreenUpdating = False
ActiveSheet.PageSetup.PrintArea = "$A$1:$AF$40"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Range("N3:P3,U3,A7:AF31,Z34,S35:S39,H34:J40") = ""
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub
Anzeige