In UF Namen sortieren

Forumthread: In UF Namen sortieren

Heinz

Guten morgen im Forum
Im unteren Code wird mir in der ComboboxSchrumpfer von Sheets Jänner von A3:A154 die Werte ausgegeben,ohne Null Werte,die auch in A3:A154 stehen können.
Funktioniert auch alles.
Könnte man diese Werte auch nach dem ABC sortieren?
Gruß
Heinz

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

AW: In UF Namen sortieren

14.01.2011 08:03:38

Josef

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

AW: In UF Namen sortieren

14.01.2011 08:24:49

Heinz

Guten morgen Sepp
Wieder einmal SUPER von dir.
Recht herzlichen DANK.
Gruß
Heinz

AW: In UF Namen sortieren

14.01.2011 08:33:57

Heinz

Hallo Josef
Ein kleiner Schönheitsfehler.
Da mir als ersters in der Combobox eine "0" angezeigt wird.
Gruß
Heinz
Userbild

AW: In UF Namen sortieren

14.01.2011 10:00:25

Josef

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

AW: In UF Namen sortieren

14.01.2011 10:04:55

Heinz

Hallo Sepp
Jetzt passt es aber zu 100%
Recht herzlichen Dank
Gruß
Heinz

Beliebteste Forumthreads (12 Monate)

Forumthread: In UF Namen sortieren

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread