Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler
If IsNumeric(Target) Then GoTo exitHandler
If IsDate(Target) Then GoTo exitHandler
If Target.HasFormula Then GoTo exitHandler
On Error GoTo exitHandler
If Target.Validation.Type <> 3 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Not Intersect(Target, Me.Range("Verein")) Is Nothing Then Exit Sub
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column >= 2 Then
If InStr(1, Target.Validation.Formula1, "=Liste") > 0 Then
If oldVal = "" Then
Else
If newVal = "" Then
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal & ", " & newVal
End If
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
If (Target.Column > 8) Then
Call floating_buttons
Else
On Error GoTo Err1:
If Target.Validation.InCellDropdown = True Then
WshShell.SendKeys ("%{DOWN}")
End If
End If
WshShell.SendKeys "%{DOWN}"
Err1:
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Worksheet_SelectionChange Target
Cancel = True
End Sub