Hallo Brezi,
so sollte es jetzt funktionieren.
Habe das jetzt nachgebaut. Ist immer blöd, wenn man nicht testen kann.
Private Sub UserForm_Initialize()
Dim oCol As New Collection
Dim Obj As Range
Dim i As Integer
TextBox1.Value = "TT.MM.JJJJ"
TextBox2.Value = "TT.MM.JJJJ"
'Daten sortiert in Collection einfügen
For Each Obj In ThisWorkbook.Worksheets("Vergabe nach VE").Range("E7:E400")
CollectionAddItem oCol, Obj.Value 'Wert in Collection
Next Obj
ComboBox1.Clear
For i = 1 To oCol.Count
ComboBox1.AddItem oCol.Item(i) 'Collection in Combobox
Next i
End Sub
Function CollectionAddItem(oCol As Collection, ByVal sItem As String, Optional iPos As Integer, Optional ByVal vKey As Variant) As Long
'Funktion fügt einen Eintrag sortiert in eine Collectionsammlung ein, Einträge können nicht mehrfach vorkommen
Dim nStart As Long, nEnd As Long, nX As Long
If Trim$(sItem) = "" Then Exit Function
With oCol
If iPos <> 0 Then
.Add sItem, vKey, iPos
ElseIf .Count < 1 Then
.Add sItem, vKey 'wenn Collection noch leer ist
'Neuen Eintrag mit 1. Eintrag vergleichen
ElseIf .Item(1) > sItem Then
.Add sItem, vKey, 1 'an 1. Position einfügen
ElseIf .Item(1) Like sItem _
Or .Item(.Count) Like sItem Then
'jetzt mit letzten Eintrag vergleichen
ElseIf .Item(.Count) < sItem Then
.Add sItem, vKey 'an letzter Position einfügen
Else
'durch binäre Suche die korrekte Position ermitteln
nStart = 1: nEnd = .Count
Do
nX = (nStart + nEnd) \ 2
If nX = nStart Then Exit Do
'Vergleich
If .Item(nX) = sItem Then Exit Function
If .Item(nX) > sItem Then nEnd = nX
If .Item(nX) < sItem Then nStart = nX
Loop
On Error Resume Next
.Add sItem, vKey, , nX
End If
End With
End Function
viele Grüße
Karl-Heinz
|