Office: Sheets zusammenfassen

Ähm ja - erstmal sorry für den langen Code.

Meine Frage: Kann man folgenden Code zu einem zusammenfassen und vor allem irgendwas machen, dass man das PW zum unlocken nur einmal eingeben muss?

 

falls das alle Tabele der Datei sind?

Code:

Option Explicit
Dim WsTabelle As Worksheet

Private Sub Aufheben()
    For Each WsTabelle In Sheets
        WsTabelle.Unprotect ("Passwort")
    Next WsTabelle
End Sub

Private Sub Schutz()
    For Each WsTabelle In Sheets
        WsTabelle.Protect ("Passwort")
    Next WsTabelle
End Sub

 

Ne sind leider nicht alle Tabellen, es gibt noch eine Tabelle die heißt "Rechner" und noch eine die heißt "Copyright"

 

für die beiden mußt Du dann ja nur die Prüfung des Namens einbauen.
also If wstabelle.name="Rechner"

 

Hallo!

Oder auch so:

Code:

Sub test()
    Dim ws As Worksheet
    For Each ws In Sheets(Array("xyz", "abc"))
        ws.Unprotect
    Next ws
End Sub

(Die Blattnamen musst du natürlich ersetzen.)

 

das kannst du folgendermaßen machen (Basis ist Hajo's Code):

Code:

Private Sub Aufheben()
    For Each WsTabelle In Sheets
        Select Case WsTabelle.Name
            Case "Rechner", "Copyright"
                ' Blattschutz wird nicht aufgehoben für diese beiden
            Case Else
                ' für alle anderen wird Blattschutz aufgehoben
                WsTabelle.Unprotect ("Passwort")
        End Select
    Next WsTabelle
End Sub

Bis später,
Karin

 

Hehe DANKE DANKE DANKE :)

werds gleich mal testen :) .. naja jetzt hab ich nur noch ein Problem ^^

Ist es möglich, dass man eine Passwortabfrage macht sobald das Sheet Adminstration angeklickt wird? Will nicht dass dort jeder Zugriff drauf hat^^

Edit:

Beim Code von schatzi muss man trotzdem das PW jedes mal neu eingeben und der Code von Beverly funktioniert ja nur wenn ich das Passwort mit reinschreib oder nicht? Weil ich hätte gerne, dass man das PW 1 mal eingeben MUSS und es dann automatisch geht. In Java würde ichs mit einem Scanner machen der sich den Wert speichert ... geht sowas in VB auch?

Ok - auch Beverlys Code geht jetzt, allerdings muss ich auch hier immer wieder das PW neu eingeben

 

Bei meinem geposteten Code muss kein PW eingegeben werden - weder am Anfang noch zwischendurch, denn es steht im Code.

Wenn eine einmalige Passwortabfrage machen willst, dann verwende ein UserForm mit einer TextBox - da kann man einstellen, dass die Eingabe nur mit Platzhaltern angezeigt wird. Dennoch musst du das PW irgendwo (im Tabellenblatt, im Code oder im UserForm) hinterlegen, damit die Eingabe verglichen werden kann.

Bis später,
Karin

 

Aso - ist ja doof.. naja hab den VBA Bereich jetzt mit einem zusätzlichen PW gesperrt. Jetzt müsste ich es nur noch schaffen, dass ein VBA Button wie eine Zelle gesperrt werden kann. Hab im Contextmenu schon auf Locked=True gestellt, funktioniert aber nicht :/

 

sooooooooo damit ihr auch wisst was ich gemeint habe und auch jeder davon etwas hat:

Code:

Private Sub CommandButton2_Click()
pw = InputBox("Passwort?")
If pw = "Passwort" Then
MsgBox "Code wird ausgeführt"
For Each WsTabelle In Sheets
        Select Case WsTabelle.Name
            Case "Rechner", "(c) Ich:P", "Administration"
                ' Blattschutz wird nicht aufgehoben für diese beiden
            Case Else
                ' für alle anderen wird Blattschutz aufgehoben
                WsTabelle.Unprotect ("Passwort")
        End Select
    Next WsTabelle
Else
MsgBox "falsch!"
End If
End Sub

Das ist der Code den ich gesucht hatte :)

 

Mh,
kann ich mit der Msgbox "falsch" auch noch automatisch ein mailto: Max.Mustermann@Mustermann.de starten? Indem auch am Besten noch ein vordefinierter Betreff so wie Absendetext steht? :)

Das würde alles noch abrunden :)

Gruß :)

 

ok wieder eine Lösung gefunden.

Hab in de elseteil ein Call MailtoSelectedNames geschrieben, das ruft dann folgendes auf:

Code:

Sub MailtoSelectedNames()
   Dim MailTo As String
   Dim cell As Range
   Dim outapp As Object, outmail As Object
   
   MailTo = "MaxMustermann@mustermann.de"
   For Each cell In Selection
      If cell.Value Like "*@*" Then
         MailTo = MailTo & ";" & cell.Value
      End If
   Next
   MailTo = Mid(MailTo, 2) ' den 1. Strichpunkt wieder löschen
   ' Debug.Print MailTo
   If MailTo = "" Then
      MsgBox "Keine gültigen eMail-Adressen gefunden!", vbCritical
      Exit Sub
   End If
   Set outapp = CreateObject("Outlook.Application")
   Set outmail = outapp.CreateItem(0)
   With outmail
      .To = MailTo
      ' .CC = ""
      .BCC = "max.mustermann@mustermann.de"
      .Subject = "Passwort vergessen"
      .Body = "Hallo Herr Mustermann, bitte setzen Sie das Passwort für die Zeiterfassungsliste zurück." _
      & " " _
      & " " _
      & " Danke" _
      ' .Attachments.Add "d:\daten\anyfile.xyz"
      .Display
      ' or use .Display
   End With
   Set outmail = Nothing
   Set outapp = Nothing
End Sub