Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA: Zellen sperren wenn nicht leer oder/und datum nicht von heute
#1
Hallo an alle,
brauche ein „bisschen“ mehr Hilfe für mein vorhaben.
 

Vorhaben:


Die Benutzer geben das Datum in die Spalte "I", "J", "L" ein. Sie können Zellen nur am ersten bzw. laufenden Tag eingeben oder wechseln.
 
Wenn die Benutzer eine Nummer bzw. einen Wert in die Spalte "K" eingeben, gilt dies dann auch für diese Spalte.
 
Benutzer können Zellen (I,J,L,K) nicht am nächsten Tag verändern.
 
Im Grunde, wenn Leer Zellen entsperrt und wenn Datum von Heute eingegeben dann morgen gesperrt
…als Anfänger, weiß ich nicht wie ich es am einfachsten erklären könnte.
 
Füge die Datei mit dem Beispiel ein, würde mich für jede hilfreiche Antwort freuen,

bitte nur zu bedenken das Sie mit einen Anfängen in VBA zu tun haben.

Beispieldatei:
.xlsm   Zellen_mit_datum_sperren.xlsm (Größe: 12,04 KB / Downloads: 3)

Danke im Voraus,
78
Niko
Antworten Top
#2
Hallo

Dazu müsste man sich merken, wann der Eintrag in der Zelle vorgenommen wurde.
Ein Möglichkeit wäre, das Editdatum in die Notiz der Zelle zu schreiben.


Versuch es mal so:
- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Rechts diesen Code reinkopieren

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Const APPNAME = "Worksheet_Change"
    On Error GoTo Fehler
    If Not Intersect(Target, Union(Columns(9), Columns(10), Columns(12))) Is Nothing Then
        With Target
            If Not .Comment Is Nothing Then
                'Ist Datum älter als Gestern
                If .Comment.Text < Date - 1 Then
                    With Application
                        MsgBox "Zelle bereits gesperrt"
                        'Wert vor Eingabe
                        .EnableEvents = False
                        .Undo
                        .EnableEvents = True
                    End With
                End If
            Else
                'Wenn Heute oder Gestern dann Notiz belegen
                If .Value <> "" Then
                    .AddComment
                    .Comment.Visible = False
                    .Comment.Text Text:=Format(Date, "DD.MM.YYYY")
                End If
            End If
        End With
       
    End If
   
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Schwachstelle:
Jemand könnte die Notiz löschen und dann trotzdem Ändern


LG UweD
[-] Folgende(r) 1 Nutzer sagt Danke an UweD für diesen Beitrag:
  • Niko
Antworten Top
#3
Vielen Dank für deine Antwort und Zeit 28 ,
doch damit kann ich die Zellen nicht nach der Datums Eingabe permanent für andere Benutzer Sperren.

Habe lange auch im Internet gesucht und diesen VBA Code gefunden, funktioniert eigentlich sehr gut.
Nur…der Code kann nicht das heutige Datum erkennen um die Datumseingabe einzuschränken bzw. zu sperren.

Code:
Dim mRg As Range
Dim mStr As String

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("I2:L10000"), Target) Is Nothing Then
    Set mRg = Target.Item(1)
    mStr = mRg.Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRg As Range
    On Error Resume Next
    Set xRg = Intersect(Range("I2:L10000"), Target)
    If xRg Is Nothing Then Exit Sub
    Target.Worksheet.Unprotect Password:="1234"
    If xRg.Value <> mStr Then xRg.Locked = True
    Target.Worksheet.Protect Password:="1234"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("I2:L10000"), Target) Is Nothing Then
    Set mRg = Target.Item(1)
     mStr = mRg.Value
End If

End Sub

Wenn die Datumsmöglichkeit in diesen Code einbauen könnte würde es mir auch helfen.

Danke,
Niko
Antworten Top
#4
Hallöchen,

das aktuelle Datum erhältst Du mit der Funktion Date.
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste