|
Hi Leute,
ich habe in meinem Excel recht viele Dropdowns mit Mehrfachauswahl & "remove if double" und dass sie sich automatisch öffnen, wenn die entsprechende Zelle angeklickt wird. Der Code funktioniert im Großen und Ganzen auch ganz gut, aber man kann es noch optimieren, nur weiß ich nicht recht, wie ich die Sache angehen soll:
1. Wenn in einem Dropdown bereits etwas drinnen steht, man klickt weg (zb. fehlklick, weil man das Dropdown-öffnen-Hakerl verfehlt hat) und dann klickt man wieder rein, muss man die Liste schließen und nochmal öffnen, dass er versteht, dass da schon etwas drinsteht - er erkennt also nicht an, dass da bereits ein Wert in dieser Zelle vorhanden ist bzw. weiß nicht, was er damit tun soll.
2. NumLock & Rollen: wenn sich ein Dropdown öffnet, aktiviert/deaktiviert sich das NumLock und/oder Rollen willkürlich (mal das eine, mal das andere, mal beides), was sehr mühsam ist. Ich habe versucht es mit keydown zu lösen, aber so richtig funktionieren tut es nicht..
Ich habe leider nicht herausgefunden, wie ich hier eine Datei hochladen kann, daher hier der Code:
PS.: Ich beschäftige mich erst seit August mit VBA und das auch nicht sonderlich intensiv. Bin also quasi blutiger Anfänger, bitte seid geduldig :D
'Dropdown mit Mehrfachauswahl & Remove if Double
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
'x = (Target.Validation)
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 '>=3 weil ab Spalte C
If InStr(1, Target.Validation.Formula1, "=Liste") > 0 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
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
'open dropdown
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If (Target.Column > 8) Then
Call floating_buttons
Else
On Error GoTo Err1:
'If Target.Cells.Count = 1 Then
If Target.Validation.InCellDropdown = True Then
Application.SendKeys ("%{DOWN}")
End If
End If
SendKeys "%{down}", True
DoEvents
'SendKeys "{SCROLLLOCK}"
Err1:
'do nothing
End Sub
|