Problem mit Dropdown-Feld

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Madlen!
Füge diesen Code in das Modul der Tabelle ein.
(Rechtsklick auf Blattregister &gt Code anzeigen &gt in das rechte Fenster einfügen)

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim varList() As Variant, lngLast As Long, lngRow As Long
With Target
  On Error Resume Next
  If .Column = 2 And .Count = 1 Then
    Columns(.Column).Validation.Delete
    Redim varList(0)
    lngLast = Cells(Rows.Count, 2).End(xlUp).Row
    For lngRow = 2 To lngLast
      If Trim$(Cells(lngRow, 2)) <> "" Then
        Redim Preserve varList(UBound(varList) + 1)
        varList(UBound(varList) - 1) = Cells(lngRow, 2)
      End If
    Next
    Redim Preserve varList(UBound(varList) - 1)
    QuickSort varList
    If IsArray(varList) Then .Validation.Add xlValidateList, Formula1:=Join(deleteDouble(varList), ",")
    .Validation.ShowError = False
    Application.SendKeys "%{DOWN}"
  End If
End With
End Sub

Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
  Do While (data(P1) < T1)
    P1 = P1 + 1
  Loop
  Do While (data(P2) > T1)
    P2 = P2 - 1
  Loop
  If P1 <= P2 Then
    T2 = data(P1)
    data(P1) = data(P2)
    data(P2) = T2
    P1 = P1 + 1
    P2 = P2 - 1
  End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub

Private Function deleteDouble(field() As Variant) As Variant
Dim varT() As Variant
Dim i As Long
Redim varT(1)
varT(0) = field(0)
For i = 1 To UBound(field)
  If field(i) <> field(i - 1) Then
    varT(UBound(varT)) = field(i)
    Redim Preserve varT(UBound(varT) + 1)
  End If
Next
Redim Preserve varT(UBound(varT) - 1)
deleteDouble = varT
End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

226 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Problem mit Dropdown-Feld

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

226 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread