Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Auflistungsklasse sortieren
zurück: Ribbon-Tab in Excel 2007 ansteuern weiter: Bedingte Formatierung auslesen Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Tutorial Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Isabelle :-)
Menschin


Verfasst am:
27. Jan 2014, 18:03
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis

Auflistungsklasse sortieren - Auflistungsklasse sortieren

Nach oben
       Version: Office 2k (2000)

Hallöchen,

das Sortieren von Auflistungsklassen die wir selbst geschrieben ist kein Problem. Ich benutze dazu den Quicksort kombiniert mit einer Move-Methode zum verschieben von Items der Klasse. Darin wird der Eintrag in eine temporäre Klasse kopiert, in der Collection gelöscht und an der angegebenen Stelle wieder eingefügt. Sortiert werden kann aufsteigend, Absteigend, per Text- oder Binärvergleich nach jeder Eigenschaft oder einem eigens gebildeten Sortierschlüssel. Dieser Sortierschlüssel wird auch, weil er eindeutig ist, zum Verschieben der Items in der Collection genutzt.

In einem Standardmodul:

Code:
Option Explicit
Option Private Module

Private lobjDataCollectionClass As clsDataCollection

Public Sub InitDataCollectionClass()

    Dim avntArray As Variant
    Dim ialngIndex As Long

    Set lobjDataCollectionClass = New clsDataCollection

    With Tabelle1
        avntArray = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp)).Value2
    End With

    With lobjDataCollectionClass

        For ialngIndex = LBound(avntArray) To UBound(avntArray)

            Call .Add(avntArray(ialngIndex, 1), _
                avntArray(ialngIndex, 2), avntArray(ialngIndex, 3))

        Next
    End With
End Sub

Public Sub Test()

    Dim objDataCollection As clsDataCollection

    'Aufsteigend nach Standard SortKey
    Call lobjDataCollectionClass.Sort

    For Each objDataCollection In lobjDataCollectionClass

        With objDataCollection

            Debug.Print .Group, .Name, .FirstName

        End With
    Next

    Debug.Print

    'Absteigend nach Name
    Call lobjDataCollectionClass.Sort(xlDescending, "Name")

    For Each objDataCollection In lobjDataCollectionClass

        With objDataCollection

            Debug.Print .Group, .Name, .FirstName

        End With
    Next

    Debug.Print

    'Aufsteigend nach Vorname
    Call lobjDataCollectionClass.Sort(xlAscending, "FirstName")

    For Each objDataCollection In lobjDataCollectionClass

        With objDataCollection

            Debug.Print .Group, .Name, .FirstName

        End With
    Next
End Sub


In einem Klassenmodul mit dem Namen "clsDataCollection":

Code:
Option Explicit

Private mstrKey As String, mstrGroup As String
Private mstrName As String, mstrFirstName As String
Private mobjDataCollection As Collection

Private Sub Class_Initialize()
    Set DataCollection = New Collection
End Sub

Private Sub Class_Terminate()
    Set DataCollection = Nothing
End Sub

Public Property Get Key() As String
    Key = mstrKey
End Property

Friend Property Let Key(ByVal pvstrKey As String)
    mstrKey = pvstrKey
End Property

Public Property Get Group() As String
    Group = mstrGroup
End Property

Friend Property Let Group(ByVal pvstrGroup As String)
    mstrGroup = pvstrGroup
End Property

Public Property Get Name() As String
    Name = mstrName
End Property

Friend Property Let Name(ByVal pvstrName As String)
    mstrName = pvstrName
End Property

Public Property Get FirstName() As String
    FirstName = mstrFirstName
End Property

Friend Property Let FirstName(ByVal pvstrFirstName As String)
    mstrFirstName = pvstrFirstName
End Property

Friend Property Get DataCollection() As Collection
    Set DataCollection = mobjDataCollection
End Property

Friend Property Set DataCollection(ByRef probjDataCollection As Collection)
    Set mobjDataCollection = probjDataCollection
End Property

Friend Sub Add( _
    ByVal pvstrGroup As String, _
    ByVal pvstrName As String, _
    ByVal pvstrFirstName As String)

    Dim objDataCollectionClass As clsDataCollection
    Dim strKey As String

    Set objDataCollectionClass = New clsDataCollection
   
    strKey = Join(Array(pvstrGroup, pvstrName, pvstrFirstName), vbNullChar)

    With objDataCollectionClass
        .Group = pvstrGroup
        .Name = pvstrName
        .FirstName = pvstrFirstName
        .Key = strKey
    End With

    Call DataCollection.Add(Item:=objDataCollectionClass, Key:=strKey)

    Set objDataCollectionClass = Nothing

End Sub

Friend Function Count() As Long
    Count = DataCollection.Count
End Function

Friend Sub Delete(ByVal pvvntIndex As Variant)
    Call DataCollection.Remove(pvvntIndex)
End Sub

Public Function Item(ByVal pvvntIndex As Variant) As clsDataCollection
'Attribute Item.VB_UserMemId = 0
    Set Item = DataCollection.Item(pvvntIndex)
End Function

Public Function NewEnum() As IUnknown
'Attribute NewEnum.VB_UserMemId = -4
    Set NewEnum = DataCollection.[_NewEnum]
End Function

Friend Sub Sort( _
    Optional ByVal opvenmSortOrder As XlSortOrder = xlAscending, _
    Optional ByVal opvstrSortKey As String = "Key", _
    Optional ByVal opvenmCompareMethod As VbCompareMethod = vbBinaryCompare, _
    Optional ByVal opvvntLBound As Variant, _
    Optional ByVal opvvntUBound As Variant)

    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim strTempKey As String

    If IsMissing(opvvntLBound) Then opvvntLBound = 1
    If IsMissing(opvvntUBound) Then opvvntUBound = Count

    lngIndex1 = opvvntLBound
    lngIndex2 = opvvntUBound

    strTempKey = CallByName(Item((lngIndex1 + lngIndex2) \ 2), opvstrSortKey, VbGet)

    Do

        If opvenmSortOrder = xlAscending Then

            Do While StrComp(CallByName(Item(lngIndex1), opvstrSortKey, VbGet), _
                strTempKey, opvenmCompareMethod) = -1

                lngIndex1 = lngIndex1 + 1

            Loop

            Do While StrComp(CallByName(Item(lngIndex2), opvstrSortKey, VbGet), _
                strTempKey, opvenmCompareMethod) = 1

                lngIndex2 = lngIndex2 - 1

            Loop

        Else

            Do While StrComp(CallByName(Item(lngIndex1), opvstrSortKey, VbGet), _
                strTempKey, opvenmCompareMethod) = 1

                lngIndex1 = lngIndex1 + 1

            Loop

            Do While StrComp(CallByName(Item(lngIndex2), opvstrSortKey, VbGet), _
                 strTempKey, opvenmCompareMethod) = -1

                lngIndex2 = lngIndex2 - 1

            Loop

        End If

        If lngIndex1 < lngIndex2 Then

            Call Move(pvvntIndex:=Item(lngIndex1).Key, _
                opvvntBefore:=Item(lngIndex2).Key)

            Call Move(pvvntIndex:=Item(lngIndex2).Key, _
                opvvntBefore:=Item(lngIndex1).Key)

            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1

        ElseIf lngIndex1 = lngIndex2 Then

            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1

        End If
    Loop Until lngIndex1 > lngIndex2

    If opvvntLBound < lngIndex2 Then Call Sort(opvenmSortOrder, opvstrSortKey, _
        opvenmCompareMethod, opvvntLBound, lngIndex2)

    If lngIndex1 < opvvntUBound Then Call Sort(opvenmSortOrder, opvstrSortKey, _
        opvenmCompareMethod, lngIndex1, opvvntUBound)

End Sub

Friend Sub Move( _
    ByVal pvvntIndex As Variant, _
    Optional ByVal opvvntBefore As Variant = Empty, _
    Optional ByVal opvvntAfter As Variant = Empty)

    On Error GoTo err_exit

    Dim objTempDataCollectionClass As clsDataCollection

    If Not IsEmpty(opvvntBefore) Then

        Set objTempDataCollectionClass = Item(pvvntIndex)

        Call Delete(pvvntIndex)

        Call DataCollection.Add(Item:=objTempDataCollectionClass, _
            Key:=pvvntIndex, Before:=opvvntBefore)

        Set objTempDataCollectionClass = Nothing

    ElseIf Not IsEmpty(opvvntAfter) Then

        Set objTempDataCollectionClass = Item(pvvntIndex)

        Call Delete(pvvntIndex)

        Call DataCollection.Add(Item:=objTempDataCollectionClass, _
            Key:=pvvntIndex, After:=opvvntAfter)

        Set objTempDataCollectionClass = Nothing

    Else
        Call MsgBox("Fehlender Parameter in der Move-Methode der " & _
            "DataCollection-Klasse.", vbCritical, "Methode fehlgeschlagen")
        End
    End If

    Exit Sub

err_exit:

    Call MsgBox("Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler in der Move-Methode")
    End
End Sub

Wie das mit den Prozedurattributen funktioniert, habe ich schon mal hier:

http://www.office-loesung.de/ftopic544234_0_0_asc.php

ganz unten erklärt.

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Isabelle :-)
Menschin


Verfasst am:
27. Jan 2014, 18:14
Rufname:
Wohnort: Westlicher Spiralarm der Galaxis


AW: Auflistungsklasse sortieren - AW: Auflistungsklasse sortieren

Nach oben
       Version: Office 2k (2000)

Und hier noch ein paar Testdaten;

Gruppe3KirmaierJosef
Gruppe1NeureutherRenate
Gruppe3KirmaierAnna
Gruppe2EbenbildKlaus
Gruppe1StenglerMaria Magdalena
Gruppe2v. SeinsfeldDietrich
Gruppe1EsserMonika
Gruppe3LieglKarl-Heinz

_________________
LG Isi

Die Mitgliedschaft im Forum erhöht deine Chance auf eine Antwort von mir um 99,999%
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: automatisches sortieren mit bezug auf anderen tabellenblatt 2 tobitobson 2040 22. Jun 2006, 10:18
tobitobson automatisches sortieren mit bezug auf anderen tabellenblatt
Keine neuen Beiträge Excel Formeln: Tabelleninhalte in neue Tabelle übernehmen u. dann sortieren 3 svahlen 1827 15. Jun 2006, 21:29
etron795 Tabelleninhalte in neue Tabelle übernehmen u. dann sortieren
Keine neuen Beiträge Excel Formeln: Sortieren 3 noobies 625 31. Mai 2006, 08:33
noobies Sortieren
Keine neuen Beiträge Excel Formeln: Automatisch sortieren 2 Rolfi 4057 28. Apr 2006, 12:04
Rolfi Automatisch sortieren
Keine neuen Beiträge Excel Formeln: Automatische sortieren 4 awi 1134 26. Apr 2006, 15:43
tom_r Automatische sortieren
Keine neuen Beiträge Excel Formeln: Werte sortieren/Reihenfolge/Rang? 5 Holger 996 1838 28. Feb 2006, 17:48
Holger 996 Werte sortieren/Reihenfolge/Rang?
Keine neuen Beiträge Excel Formeln: Liste automatisch nach Text (Namen) sortieren 5 Frost 11104 29. Jan 2006, 21:45
ransi Liste automatisch nach Text (Namen) sortieren
Keine neuen Beiträge Excel Formeln: Mappen sortieren 1 El-Aix 1740 28. Nov 2005, 19:40
ae Mappen sortieren
Keine neuen Beiträge Excel Formeln: automatisches Sortieren 1 dope 1046 13. Sep 2005, 16:58
ae automatisches Sortieren
Keine neuen Beiträge Excel Formeln: Zufallszahl-Kolumnen sortieren 3 Detlef 42 1234 03. Sep 2005, 15:57
Detlef 42 Zufallszahl-Kolumnen sortieren
Keine neuen Beiträge Excel Formeln: nach neuen Eintrag in Tabelle automatisch sortieren 6 maddoc 2358 08. Jun 2005, 23:06
maddoc nach neuen Eintrag in Tabelle automatisch sortieren
Keine neuen Beiträge Excel Formeln: Makro fürs Sortieren 2 nhs47800 1951 11. Mai 2005, 09:47
nhs Makro fürs Sortieren
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: MS Frontpage