Einträge in Fahrzeugverwaltung schützen

Hallo Leute
Ich bin gerade dabei eine Fahrzeugverwaltung zu basteln. Es funktioniert auch alles prima. siehe: https://www.herber.de/bbs/user/29195.xls
Allerdings bleibt ein Problem. Die Reservierungen könnten theoretisch von jedem wieder manipuliert werden. Kann man die Einträge meiner Reservierungstabelle irgendwie per VBA mit einem Passwort schützen? Das heißt das ich eine Reservierung mache und nur ich die wieder ändern bzw löschen kann. Nach Ablauf der Reservierung kann sie dann jeder löschen...
Ich hoffe mein Problem einigermaßen erklärt zu haben.
Die Fahrzeugverwaltung habe ich angehängt. Schaut sie euch doch bitte mal an. Über Rückmeldung jeder Art danke ich im vorraus..
Vielleicht hat ja auch jemand eine andere Idee, das Problem zu lösen.
mfg
Mark

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Einträge_löschen() Dim zei, n As Integer Application.ScreenUpdating = False ActiveSheet.Unprotect zei = Array(9, 10, 11, 52, 62) 'anpassen For n = 0 To UBound(zei) If Cells(zei(n), 12) = "1" Then Range(Cells(zei(n), 3), Cells(zei(n), 9)).ClearContents Next n Die Sortierung dann so: Range("A9:G12").Sort Key1:=Range("A9"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal

Private Sub Worksheet_Change(ByVal Target As Range) Set Bereich = Application.Union(Range("A1:H3"), Range("A5:H8"), Range("A10:H13")) 'Anpassen If Not Intersect(Target, Bereich) = False Then 'Blattschutz setzen End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set Bereich = Application.Union(Range("A1:H3"), Range("A5:H8"), Range("A10:H13")) 'Anpassen If Not Application.Intersect(Target, Bereich) = False Then eing = InputBox("Passw") If eing <> "xyz" Then Exit Sub 'Blattschutz aufheben End If End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'On Error Resume Next 'MsgBox Application.Caller 'If Application.Caller = "Schaltfläche 1" Then Exit Sub Set Bereich = Application.Union(Range("C9:G9"), Range("C10:G10"), Range("C11:G11")) If Not Application.Intersect(Target, Bereich) Is Nothing Then eing = InputBox("Passwort") If eing <> "xyz" Then Exit Sub 'Blattschutz aufheben End If End Sub

Hi Mark,
wirf meinen Code raus. ann Doppelklick auf DieseArbeitsmappe. Neuen Code einfügen, ggfs Blattnamen, Passwörter anpasssen. dann Code mit Passwort schützen sodaß nur du ihn ändern/ansehen kannst.

Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Worksheets("Tabelle1").Protect password:="xyz", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Private Sub Workbook_Open()
Dim Worte, eing, n, richtig
Worte = Array("Paul", "Peter", "Lisa")
eing = InputBox("Passwort")
For n = 0 To UBound(Worte)
If UCase(eing) = UCase(Worte(n)) Then richtig = True
Next n
If richtig = True Then Worksheets("Tabelle1").Unprotect ("xyz")
End Sub

Gruß
Reinhard
ps:Das Forum lebt auch von Rückmeldungen

Beliebteste Forumthreads (12 Monate)

Einträge in Fahrzeugverwaltung schützen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Einträge in Fahrzeugverwaltung schützen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread