Zellen nach eingabe von Werten automatisch sperren

Hallo alle zusammen
Ich möchte meinen Kollegen eine BundesligaTippTabelle zur verfügung stellen. Das ist aber nicht das Problem. Mein Problem ist, daß ich nicht weis wie man Zellen in die gerade Werte eingegben wurden automatisch sperren kann. Ich stelle mir folgendes vor: Spieler 1 gibt seine Werte in seine Spalte ein und speichert die Datei und nun sind diese Zellen gesperrt. Wenn Spieler 2 nun seine Werte in seine Spalte eingibt sollen diese Zellen offen sein und nach einem weiteren speichern auch gesperrt sein. Er darf aber nicht die Werte von Spieler 1 ändern oder gar löschen können. Der normale Zellschutz über den Blattschutz hilft mir hier nicht weiter. Einen kleinen Teil der Tabelle (Spieltag 1) habe ich mal eingefügt, damit Ihr euch vielleicht ein besseres Bild machen könnt.

Die Datei https://www.herber.de/bbs/user/8220.xls wurde aus Datenschutzgründen gelöscht

Ich hoffe Ihr könnt mir helfen obwohl ich nicht mehr zu retten bin.
MfG ElGuano

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim zelle As Range Sheets(1).Unprotect For Each zelle In Sheets(1).UsedRange If zelle.Value <> "" Then zelle.Locked = True Else zelle.Locked = False End If Next Sheets(1).Protect End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim Mldg As Byte If ActiveWorkbook.Saved Then Sheets("Tabelle1").Visible = True For InI = Sheets.Count To 1 Step -1 If Sheets(InI).Name <> "Tabelle1" Then Sheets(InI).Visible = xlVeryHidden Next InI ByS = True ThisWorkbook.Save Else If ByS = True Then Exit Sub Mldg = MsgBox(" Sollen die Veränderungen gespeichertg werden ?", _ vbYesNo + vbQuestion, "Speicher abfrage ?", "", 0) If Mldg = 6 Then Application.ScreenUpdating = False Sheets("Tabelle1").Visible = True For InI = Sheets.Count To 1 Step -1 If Sheets(InI).Name <> "Tabelle1" Then Sheets(InI).Visible = xlVeryHidden Next InI ByS = True ThisWorkbook.Save Application.ScreenUpdating = True Else ByS = True ThisWorkbook.Close False End If End If End Sub

Private Sub Workbook_Open() Sheets("Spieltag 1").Unprotect ("excel") Application.ScreenUpdating = False For InI = Sheets.Count To 1 Step -1 Sheets(InI).Visible = True Next InI Sheets("Tabelle1").Visible = False ActiveWorkbook.Saved = True 'On Error Resume Next Sheets("Spieltag 1").Cells.SpecialCells(xlCellTypeConstants, 23).Locked = True Sheets("Spieltag 1").Cells.SpecialCells(xlCellTypeFormulas, 23).Locked = True Sheets("Spieltag 1").Cells.SpecialCells(xlCellTypeBlanks).Locked = False Application.ScreenUpdating = True Sheets("Spieltag 1").Protect ("excel") End Sub

Hallo zusammen
Ich möchte mich bei allen bedanken die mir mit Rat und Tat zur Seite standen und mein Problem gelöst haben. Insbesonder bedanke ich mich bei AndrèL, Silvio, Excel und Martin Beck. Damit alle etwas von der Lösung haben, stelle ich hier den Code ein, der von Excel erstellt von Martin Beck den entscheidenden Hinweisgegeben und von Andrè vollendet wurde. Meine wenigkeit hat alles nur getestet und mich in den meisten Fällen beklagen müssen das es immer noch nicht läuft. Sollte ich dabei jemandem zu nahe getreten sein, entschuldige ich mich hiermit.
Der Lösungs Code lautet wie folgt
Dim InI As Integer
Dim ByS As Boolean


Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Mldg As Byte
If ActiveWorkbook.Saved Then
Sheets("Tabelle1").Visible = True
For InI = Sheets.Count To 1 Step -1
If Sheets(InI).Name <> "Tabelle1" Then Sheets(InI).Visible = xlVeryHidden
Next InI
ByS = True
ThisWorkbook.Save
Else
If ByS = True Then Exit Sub
Mldg = MsgBox(" Sollen die Veränderungen gespeichert werden ?", _
vbYesNo + vbQuestion, "Speicher abfrage ?", "", 0)
If Mldg = 6 Then
Application.ScreenUpdating = False
Sheets("Tabelle1").Visible = True
For InI = Sheets.Count To 1 Step -1
If Sheets(InI).Name <> "Tabelle1" Then Sheets(InI).Visible = xlVeryHidden
Next InI
ByS = True
ThisWorkbook.Save
Application.ScreenUpdating = True
Else
ByS = True
ThisWorkbook.Close False
End If
End If
End Sub


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If ByS = False Then
Cancel = True
MsgBox "Datei kann nur beim schließen gespeichert werden"
End If
End Sub


Private Sub Workbook_Open()
Application.ScreenUpdating = False
For InI = 1 To Sheets.Count 'To 1 Step -1
Sheets(InI).Visible = True
Next InI
Sheets("Tabelle1").Visible = False
For sh = 1 To Sheets.Count
If Left(Sheets(sh).Name, 9) = "Spieltag " Then
Sp = Sp + 1
Sheets("Spieltag " & Sp).Unprotect ("Excel")
Sheets("Spieltag " & Sp).Cells.SpecialCells(xlCellTypeConstants, 23).Locked = True
Sheets("Spieltag " & Sp).Cells.SpecialCells(xlCellTypeFormulas, 23).Locked = True
Sheets("Spieltag " & Sp).Cells.SpecialCells(xlCellTypeBlanks).Locked = False
Sheets("Spieltag " & Sp).Protect ("Excel")
End If
Next sh
ActiveWorkbook.Saved = True
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Zellen nach eingabe von Werten automatisch sperren

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

172 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen nach eingabe von Werten automatisch sperren

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

172 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread