dropdownmenue nicht "selbstentleerend"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range, arr As Variant, tmp() As Variant, n As Integer, k As Integer
Set rng = Range("A2:M40")
If Not Intersect(Target, rng) Is Nothing Then
On Error GoTo ErrExit
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
End With
rng.Validation.Delete
Select Case Me.Cells(1, Target.Column).Text
Case "Vorarbeiter"
arr = Sheets("Liste").Range("vorarb")
Case "Helfer"
arr = Sheets("Liste").Range("helfer")
Case "Azubis"
arr = Sheets("Liste").Range("azubi")
Case Else
GoTo ErrExit
End Select
For n = 1 To UBound(arr, 1)
If Application.CountIf(rng, Trim$(arr(n, 1))) = 0 Then
If arr(n, 1) <> "" Then
ReDim Preserve tmp(k)
tmp(k) = Trim$(arr(n, 1))
k = k + 1
End If
End If
Next
With Target.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(tmp, ",")
End With
If Target.Count = 1 Then Application.SendKeys "%{DOWN}"
End If
ErrExit:
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub