Thomas Risi Softwareentwicklung
Addins - Datenbanklösungen - Komponenten - RTDServer - WebServices
Sortieren einer ListBox
Diese Beispiele erläutern die Sortierung einer ListBox, die in einer
UserForm enthalten ist.
Um Beispiel 1 nachvollziehen zu können, benötigen Sie also eine UF namens
UserForm1 mit einer ListBox namens ListBox1. Für Beispiel 2 ist
zusätzlich ein Klassenmodul erforderlich, das Sie mit clsListBox benennen.
Des weiteren wird davon ausgegangen, daß sich die Daten im Bereich 'A1:A20'
befinden.
Nach dem Start der UF's werden die Daten in der ListBox aufgelistet, natürlich sortiert ...
Die Klasse hat zusätzlich eine einfache Highlighting - Funktion zu
bieten. Vielleicht hat ja jemand Lust, der Klasse noch etwas mehr Funktionalität
zu verleihen ;-)
Beispiel 1: Code für UserForm ...
Option Explicit
Private Sub UserForm_Initialize()
Dim MyList() As Variant
Dim MyRange As Excel.Range
Dim i As Long
Set MyRange = Range("A1:A20")
ReDim MyList(0 To MyRange.Count - 1)
For i = 0 To MyRange.Count - 1
MyList(i) = MyRange(i + 1).Value
Next i
ShellSort MyList
ListBox1.List() = MyList
End Sub
Sub ShellSort(ByRef data() As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = UBound(data)
k = OG \ 2
While k > 0
For i = 0 To OG - k
j = i
While (j >= 0) And (data(j) > data(j + k))
h = data(j)
data(j) = data(j + k)
data(j + k) = h
If j > k Then
j = j - k
Else
j = 0
End If
Wend
Next i
k = k \ 2
Wend
End Sub
Beispiel 1: Code für UserForm (aber etwas kürzer) ...
Option Explicit
Private Sub UserForm_Initialize()
ListBox1.RowSource = "A1:A20"
ShellSort ListBox1.List
End Sub
Sub ShellSort(ByRef data As Variant)
Dim OG&, i&, j&, k&, h As Variant
OG = UBound(data)
k = OG \ 2
While k > 0
For i = 0 To OG - k
j = i
While (j >= 0) And (data(j, 0) > data(j + k, 0))
h = data(j, 0)
data(j, 0) = data(j + k, 0)
data(j + k, 0) = h
If j > k Then
j = j - k
Else
j = 0
End If
Wend
Next i
k = k \ 2
Wend
End Sub
Beispiel 2: Code für UserForm ...
Option Explicit
Dim mListBoxes(1 To 1) As New clsListBox
Private Sub UserForm_Initialize()
mListBoxes(1).SetListBox(Range("Tabelle1!A1:A20")) = ListBox1
End Sub
Option Explicit
Dim FirstRun As Boolean
Dim MyList() As Variant
Dim WithEvents WS As Excel.Worksheet
Dim MyRange As Excel.Range
Dim WithEvents MyListBox As MSForms.ListBox
Public Property Let SetListBox(List As Range, LB As MSForms.ListBox)
Set MyListBox = LB
Set MyRange = List
Set WS = MyRange.Worksheet
MyList = MyRange
QuickSort MyList, 1
MyListBox.List() = MyList
End Property
Private Sub Class_Initialize()
FirstRun = False
End Sub
Private Sub Class_Terminate()
Set WS = Nothing
Set MyRange = Nothing
Set MyListBox = Nothing
End Sub
Private Sub MyListBox_Change()
FirstRun = False
QuickSort MyList, 1
End Sub
Sub QuickSort(data() As Variant, Optional ByVal Index, _
Optional ByVal UG, Optional ByVal OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
If Not FirstRun Then
Index = IIf(IsMissing(Index), 1, Index)
UG = IIf(IsMissing(UG), LBound(data, Index), UG)
OG = IIf(IsMissing(OG), UBound(data, Index), OG)
FirstRun = True
End If
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2, Index)
Do
Do While (data(P1, Index) < T1)
P1 = P1 + 1
Loop
Do While (data(P2, Index) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1, Index)
data(P1, Index) = data(P2, Index)
data(P2, Index) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, Index, UG, P2
If P1 < OG Then QuickSort data, Index, P1, OG
End Sub
Private Sub MyListBox_Click()
Dim i As Range
For Each i In MyRange
If i.Value = MyListBox.Value Then i.Interior.ColorIndex = 4
Next i
End Sub
Private Sub MyListBox_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MyRange.Interior.ColorIndex = 0
End Sub
Private Sub WS_Change(ByVal Target As Range)
MyList = MyRange
FirstRun = False
QuickSort MyList, 1
MyListBox.List() = MyList
End Sub
© 2001 -
by Thomas Risi