Thema Datum  Von Nutzer Rating
Antwort
26.11.2020 18:02:18 brezi
Solved
26.11.2020 18:04:57 Gast90639
NotSolved
27.11.2020 10:32:15 volti
Solved
27.11.2020 10:39:13 volti
NotSolved
27.11.2020 11:01:37 brezi
Solved
27.11.2020 11:54:33 volti
NotSolved
27.11.2020 16:44:57 brezi
Solved
27.11.2020 17:52:30 volti
NotSolved
Rot UserForm Array into BubbleSort
27.11.2020 19:56:12 volti
Solved
30.11.2020 11:48:07 brezi
NotSolved
30.11.2020 12:03:01 volti
Solved
30.11.2020 12:13:41 brezi
NotSolved
30.11.2020 13:00:38 volti
Solved
30.11.2020 14:08:49 brezi
Solved
30.11.2020 14:10:50 volti
NotSolved
27.11.2020 11:09:13 RPP63
NotSolved
27.11.2020 11:13:50 brezi
NotSolved

Ansicht des Beitrags:
Von:
volti
Datum:
27.11.2020 19:56:12
Views:
511
Rating: Antwort:
 Nein
Thema:
UserForm Array into BubbleSort

Hallo Brezi,

falls das mit der SortedList nicht klappen sollte und Du die anderen vorgeschlagenen Varianten nicht verwenden willst oder kannst, gäbe es noch die Möglichkeit, selbst über eine Collection zu sortieren, ähnlich wie bei Deinem BubbleSort allerdingsdeutlich schneller.

Ist jedoch deutlich mehr Code.

Sub Test()
 Dim Obj As Range, sArr() As String, i As Integer, oCol As New Collection

 For Each Obj In ThisWorkbook.Worksheets("Vergabe nach VE").Range("E7:E400")
     CollectionAddItem oCol, Obj.Value  'Wert in Collection
 Next Obj
 For i = 0 To oCol.Count - 1
     sArr(i) = oCol.Item(i + 1)         'Collection in Array
 Next i
 Combobox1.List = sArr                  'Array in Combobox ausgeben
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


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
26.11.2020 18:02:18 brezi
Solved
26.11.2020 18:04:57 Gast90639
NotSolved
27.11.2020 10:32:15 volti
Solved
27.11.2020 10:39:13 volti
NotSolved
27.11.2020 11:01:37 brezi
Solved
27.11.2020 11:54:33 volti
NotSolved
27.11.2020 16:44:57 brezi
Solved
27.11.2020 17:52:30 volti
NotSolved
Rot UserForm Array into BubbleSort
27.11.2020 19:56:12 volti
Solved
30.11.2020 11:48:07 brezi
NotSolved
30.11.2020 12:03:01 volti
Solved
30.11.2020 12:13:41 brezi
NotSolved
30.11.2020 13:00:38 volti
Solved
30.11.2020 14:08:49 brezi
Solved
30.11.2020 14:10:50 volti
NotSolved
27.11.2020 11:09:13 RPP63
NotSolved
27.11.2020 11:13:50 brezi
NotSolved