Registriert seit: 16.10.2014
Version(en): 2013
Guten morgen zusammen,
kaum hat sich ein Thema erledigt, schon steh ich vor dem nächsten Problem. Ich habe eine Tabelle mit den Spalten A - D und Zeilen 1-20. In jeder Zelle ist die gleiche Gültigkeit hinterlegt. Hier können sich Mitarbeiter mit Namenskürzeln eintragen, die zu einer bestimmten Zeit Arbeiten wollen. Gibt es eine Möglichkeit, dass sich die Mitarbeiter zwar eintragen können, jedoch nicht löschen können. Es kommt immer wieder vor, dass andere durch den Eintrag gelöscht werden.
Hätte da jemand eine Lösung ?
Gruß Fred
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Fred,
folgender Code kommt in das schon vorhandene VBA-Modul des entsprechenden Tabellenblattes:
----------------------------------------------------------------------------
Code:
Private Sub Worksheet_Change( ByVal Target As Range)
Dim varEintrag As Variant
If Not Application.Intersect(Range( "A1:D20"), Target) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
If Target.Count > 1 Then
Application.Undo
Else
varEintrag = Target.Value
Application.Undo
If IsEmpty(Target) Then
Target.Value = varEintrag
Else
MsgBox "Eintag ist nur in einer leeren Zelle möglich!", vbCritical
End If
Application.EnableEvents = True
On Error GoTo 0
End If
End If
End Sub
----------------------------------------------------------------------------
VBA/HTML - CodeConverter für Excelforen
AddIn für Excel 2002-2013 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch René Holtz (alias mumpel)
Code erstellt und getestet in Office 14
----------------------------------------------------------------------------
Die Datei muss dann aber mit der Endung .xlsm oder xlsb gespeichert werden.
Gruß Uwe
Registriert seit: 16.10.2014
Version(en): 2013
15.12.2015, 02:58
(Dieser Beitrag wurde zuletzt bearbeitet: 15.12.2015, 08:25 von Rabe.
Bearbeitungsgrund: Code durch 5. Button von rechts strukturiert dargestellt
)
Hallo Uwe,
ich habe bereits folgenden Code drinnen und wenn ich deinen hinten an setze dann funktioniert das nicht. Was mach ich falsch?
Der Code, den ich bereits habe, ist:
Code: Const bolSorted As Boolean = True ' Legt fest, ob die Werte noch sortiert werden.
Dim blockedEvent As Boolean
Dim TargetOldText As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strResult As String
Dim strTarget As String
Dim arrSorted As Variant
Dim i As Long
If Target.Column = 13 Or Target.Column = 24 Then
strTarget = Trim$(Target.Value)
If Not blockedEvent Then
blockedEvent = True
If Not TargetOldText = "" And Not Target.Value = "" Then
If InStr(1, TargetOldText, Target.Value) > 0 Then
strResult = Replace(TargetOldText, ", " & strTarget, "")
strResult = Replace(strResult, strTarget & ", ", "")
strResult = Replace(strResult, strTarget, "")
Else
strResult = TargetOldText & ", " & Target.Value
End If
If bolSorted Then
arrSorted = Split(strResult, ", ")
strResult = ""
Call Selectionsort(arrSorted)
For i = 0 To UBound(arrSorted)
strResult = strResult & arrSorted(i) & ", "
Next i
If Len(strResult) > 1 Then _
strResult = Left$(strResult, Len(strResult) - 2)
End If
Target.Value = strResult
Else
Target.Value = Target.Value
End If
TargetOldText = Target.Value
Else
blockedEvent = False
End If
Else
TargetOldText = ""
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target.Column = TargetColumn Then
TargetOldText = Target.Value
End If
End Sub
Private Sub Selectionsort(ByRef data As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = UBound(data)
For i = 0 To OG - 1
h = data(i)
k = i
For j = i + 1 To OG
If data(j) < h Then
h = data(j)
k = j
End If
Next j
data(k) = data(i)
data(i) = h
Next i
End Sub
Wie bring ich jetzt deinen code noch mit unter?
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
15.12.2015, 07:31
(Dieser Beitrag wurde zuletzt bearbeitet: 15.12.2015, 07:31 von Kuwer.)
Hallo Fred,
so vielleicht:
Microsoft Excel Objekt Tabelle1Option Explicit
Const bolSorted As Boolean = True ' Legt fest, ob die Werte noch sortiert werden.
Dim blockedEvent As Boolean
Dim TargetOldText As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varEintrag As Variant
Dim strResult As String
Dim strTarget As String
Dim arrSorted As Variant
Dim i As Long
If Not Application.Intersect(Range("A1:D20"), Target) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
If Target.Count > 1 Then
Application.Undo
Else
varEintrag = Target.Value
Application.Undo
If IsEmpty(Target) Then
Target.Value = varEintrag
Else
MsgBox "Eintag ist nur in einer leeren Zelle möglich!", vbCritical
End If
Application.EnableEvents = True
On Error GoTo 0
End If
End If
If Target.Column = 13 Or Target.Column = 24 Then
strTarget = Trim$(Target.Value)
If Not blockedEvent Then
blockedEvent = True
If Not TargetOldText = "" And Not Target.Value = "" Then
If InStr(1, TargetOldText, Target.Value) > 0 Then
strResult = Replace(TargetOldText, ", " & strTarget, "")
strResult = Replace(strResult, strTarget & ", ", "")
strResult = Replace(strResult, strTarget, "")
Else
strResult = TargetOldText & ", " & Target.Value
End If
If bolSorted Then
arrSorted = Split(strResult, ", ")
strResult = ""
Call Selectionsort(arrSorted)
For i = 0 To Ubound(arrSorted)
strResult = strResult & arrSorted(i) & ", "
Next i
If Len(strResult) > 1 Then _
strResult = Left$(strResult, Len(strResult) - 2)
End If
Target.Value = strResult
Else
Target.Value = Target.Value
End If
TargetOldText = Target.Value
Else
blockedEvent = False
End If
Else
TargetOldText = ""
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TargetOldText = Target.Value
End Sub
Private Sub Selectionsort(ByRef data As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = Ubound(data)
For i = 0 To OG - 1
h = data(i)
k = i
For j = i + 1 To OG
If data(j) < h Then
h = data(j)
k = j
End If
Next j
data(k) = data(i)
data(i) = h
Next i
End Sub
Gruß Uwe
Registriert seit: 16.10.2014
Version(en): 2013
Hallo Uwe,
die Formel passt hervorragend aber jetzt hab ich das Problem das ich einen Eintrag der aus versehen eingetragen worden ist nicht löschen kann. Gäbe es noch eine Version wo es eine Möglichkeit gibt dass hier der Eintrag evtl. über Passwort gelöscht werden kann ??
Gruß Fred
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
17.12.2015, 19:34
(Dieser Beitrag wurde zuletzt bearbeitet: 17.12.2015, 19:34 von Kuwer.)
Hallo Fred,
teste mal so:
Option Explicit
Const bolSorted As Boolean = True ' Legt fest, ob die Werte noch sortiert werden.
Dim blockedEvent As Boolean
Dim TargetOldText As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varEintrag As Variant
Dim strResult As String
Dim strTarget As String
Dim arrSorted As Variant
Dim i As Long
If Not Application.Intersect(Range("A1:D20"), Target) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
If Target.Count > 1 Then
Application.Undo
Else
If IsEmpty(Target) Then
varEintrag = InputBox("Bitte das Löschen mit Kennwort bestätigen!") = "Passwort"
End If
If Not varEintrag Then
varEintrag = Target.Value
Application.Undo
If IsEmpty(Target) Then
Target.Value = varEintrag
Else
MsgBox "Eintag ist nur in einer leeren Zelle möglich!", vbCritical
End If
End If
End If
Application.EnableEvents = True
On Error GoTo 0
End If
If Target.Column = 13 Or Target.Column = 24 Then
strTarget = Trim$(Target.Value)
If Not blockedEvent Then
blockedEvent = True
If Not TargetOldText = "" And Not Target.Value = "" Then
If InStr(1, TargetOldText, Target.Value) > 0 Then
strResult = Replace(TargetOldText, ", " & strTarget, "")
strResult = Replace(strResult, strTarget & ", ", "")
strResult = Replace(strResult, strTarget, "")
Else
strResult = TargetOldText & ", " & Target.Value
End If
If bolSorted Then
arrSorted = Split(strResult, ", ")
strResult = ""
Call Selectionsort(arrSorted)
For i = 0 To UBound(arrSorted)
strResult = strResult & arrSorted(i) & ", "
Next i
If Len(strResult) > 1 Then _
strResult = Left$(strResult, Len(strResult) - 2)
End If
Target.Value = strResult
Else
Target.Value = Target.Value
End If
TargetOldText = Target.Value
Else
blockedEvent = False
End If
Else
TargetOldText = ""
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TargetOldText = Target.Value
End Sub
Private Sub Selectionsort(ByRef data As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = UBound(data)
For i = 0 To OG - 1
h = data(i)
k = i
For j = i + 1 To OG
If data(j) < h Then
h = data(j)
k = j
End If
Next j
data(k) = data(i)
data(i) = h
Next i
End Sub
Gruß Uwe
Registriert seit: 16.10.2014
Version(en): 2013
Hallo Uwe,
erstmal vielen Dank das passt ganz klasse nur wie komm ich an das Kennwort bzw. wo geb ich das ein.
wie sähe denn der Code aus wenn es noch einen Zweiten seperaten Bereich E1-F20 geben würde für den die selben Regeln gelten würden.
Gruß Fred
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Fred,
ändere die Zeile
If Not Application.Intersect(Range("A1:D20"), Target) Is Nothing Then
zu
If Not Application.Intersect(Target, Range("A1:D20", "E1:F20")) Is Nothing Then
Das Passwort steht in der Zeile
varEintrag = InputBox("Bitte das Löschen mit Kennwort bestätigen!") = "Passwort"
Option Explicit
Const bolSorted As Boolean = True ' Legt fest, ob die Werte noch sortiert werden.
Dim blockedEvent As Boolean
Dim TargetOldText As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim varEintrag As Variant
Dim strResult As String
Dim strTarget As String
Dim arrSorted As Variant
Dim i As Long
If Not Application.Intersect(Target, Range("A1:D20", "E1:F20")) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
If Target.Count > 1 Then
Application.Undo
Else
If IsEmpty(Target) Then
varEintrag = InputBox("Bitte das Löschen mit Kennwort bestätigen!") = "Passwort"
End If
If Not varEintrag Then
varEintrag = Target.Value
Application.Undo
If IsEmpty(Target) Then
Target.Value = varEintrag
Else
MsgBox "Eintag ist nur in einer leeren Zelle möglich!", vbCritical
End If
Else
MsgBox "Der Eintrag wurde nicht gelöscht, das das Kennwort falsch war!", vbCritical
End If
End If
Application.EnableEvents = True
On Error GoTo 0
End If
If Target.Column = 13 Or Target.Column = 24 Then
strTarget = Trim$(Target.Value)
If Not blockedEvent Then
blockedEvent = True
If Not TargetOldText = "" And Not Target.Value = "" Then
If InStr(1, TargetOldText, Target.Value) > 0 Then
strResult = Replace(TargetOldText, ", " & strTarget, "")
strResult = Replace(strResult, strTarget & ", ", "")
strResult = Replace(strResult, strTarget, "")
Else
strResult = TargetOldText & ", " & Target.Value
End If
If bolSorted Then
arrSorted = Split(strResult, ", ")
strResult = ""
Call Selectionsort(arrSorted)
For i = 0 To UBound(arrSorted)
strResult = strResult & arrSorted(i) & ", "
Next i
If Len(strResult) > 1 Then _
strResult = Left$(strResult, Len(strResult) - 2)
End If
Target.Value = strResult
Else
Target.Value = Target.Value
End If
TargetOldText = Target.Value
Else
blockedEvent = False
End If
Else
TargetOldText = ""
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TargetOldText = Target.Value
End Sub
Private Sub Selectionsort(ByRef data As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = UBound(data)
For i = 0 To OG - 1
h = data(i)
k = i
For j = i + 1 To OG
If data(j) < h Then
h = data(j)
k = j
End If
Next j
data(k) = data(i)
data(i) = h
Next i
End Sub
Gruß Uwe
Registriert seit: 16.10.2014
Version(en): 2013
Hallo Uwe,
hab noch das Problem mit dem Kennwort, wenn ich statt dem Eintrag PASSWORT ein neues Wort einfüge kommt immer noch -falsches kennwort-.-
Gruß Fred
Registriert seit: 16.10.2014
Version(en): 2013
Sorry wenn ich mich falsch ausgedrückt habe es kommt die Meldung, konnte nicht gelöscht werden da Passwort falsch war.
|
