In UF Namen sortieren

Private Sub UserForm_Activate() Dim x As Long ComboBoxSchrumpfer.Clear With Worksheets("Jänner") For x = 3 To 154 'Zeile 3 bis 154 nur in Liste anlegen, wenn ungleich Null If .Cells(x, 1).Value 0 Then ComboBoxSchrumpfer.AddItem .Cells(x, 1) Next End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Heinz,
eine Möglichkeit.

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

Option Explicit

Private Sub UserForm_Activate()

  With ComboBoxSchrumpfer
    .Clear
    .List = UniqueList(Sheets("Jänner").Range("A3:A154"))
  End With

End Sub

Function UniqueList(Matrix As Range, Optional Sorted As Boolean = True) As Variant
  Dim objDic As Object, rng As Range, varTmp() As Variant

  Set objDic = CreateObject("Scripting.Dictionary")

  For Each rng In Matrix
    If rng.Value <> "" Then objDic(rng.Value) = 0
  Next

  varTmp = objDic.keys

  If Sorted Then QuickSort varTmp

  UniqueList = varTmp

  Set objDic = Nothing
End Function

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

Gruß Sepp

Hallo Heinz,
dann so.

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

Option Explicit

Private Sub UserForm_Activate()

  With ComboBoxSchrumpfer
    .Clear
    .List = UniqueList(Sheets("Jänner").Range("A3:A154"))
  End With

End Sub

Function UniqueList(Matrix As Range, Optional Sorted As Boolean = True) As Variant
  Dim objDic As Object, rng As Range, varTmp() As Variant

  Set objDic = CreateObject("Scripting.Dictionary")

  For Each rng In Matrix
    If rng.Value <> 0 Then objDic(rng.Value) = 0
  Next

  varTmp = objDic.keys

  If Sorted Then QuickSort varTmp

  UniqueList = varTmp

  Set objDic = Nothing
End Function

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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

In UF Namen sortieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread