18.12.2015, 08:52
Hallo Fred,
wie sieht es jetzt aus?
Gruß Uwe
wie sieht es jetzt aus?
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 arrSorted As Variant
Dim bolKennwort As Boolean
Dim i As Long
Dim strResult As String
Dim strTarget As String
Dim varEintrag As Variant
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
bolKennwort = InputBox("Bitte das Löschen mit Kennwort bestätigen!") = "Passwort"
If bolKennwort = False Then
MsgBox "Der Eintrag wird nicht gelöscht, da das Kennwort falsch war!", vbCritical
End If
End If
If bolKennwort = False 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
Exit Sub
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
