VBA de la matrice de la fonction de tri?

Question

Je suis à la recherche pour un bon tri de mise en œuvre pour les tableaux en VBA. Un Quicksort serait préférable. Ou tout autre algorithme de tri autre que la bulle ou la fusion devrait suffire.

Veuillez noter que ceci est de travailler avec MS Project 2003, ce qui devrait éviter toute Excel fonctions natives et n'importe quoi .net liée.

Answer 1

Prendre un coup d'oeil ici:

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub

Answer 2

J'ai converti le rapide de rapide de tri de l'algorithme de VBA, si quelqu'un d'autre veut.

Je l'ai optimisé pour fonctionner sur un tableau de Int/Longs, mais il doit être simple pour convertir un qui travaille sur l'arbitraire des éléments comparables.

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
    Dim M As Long, i As Long, j As Long, v As Long
    M = 4

    If ((r - l) > M) Then
        i = (r + l) / 2
        If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
        If (a(l) > a(r)) Then swap a, l, r
        If (a(i) > a(r)) Then swap a, i, r

        j = r - 1
        swap a, i, j
        i = l
        v = a(j)
        Do
            Do: i = i + 1: Loop While (a(i) < v)
            Do: j = j - 1: Loop While (a(j) > v)
            If (j < i) Then Exit Do
            swap a, i, j
        Loop
        swap a, i, r - 1
        QuickSort a, l, j
        QuickSort a, i + 1, r
    End If
End Sub

Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
    Dim T As Long
    T = a(i)
    a(i) = a(j)
    a(j) = T
End Sub

Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
    Dim i As Long, j As Long, v As Long

    For i = lo0 + 1 To hi0
        v = a(i)
        j = i
        Do While j > lo0
            If Not a(j - 1) > v Then Exit Do
            a(j) = a(j - 1)
            j = j - 1
        Loop
        a(j) = v
    Next i
End Sub

Public Sub sort(ByRef a() As Long)
    QuickSort a, LBound(a), UBound(a)
    InsertionSort a, LBound(a), UBound(a)
End Sub

Answer 3

Explication en allemand, mais le code est testé en place de mise en œuvre:

Private Sub QuickSort(ByVal Field() As String, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

Invoquée comme ceci:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Answer 4

Nombre Naturel (Chaînes De Caractères) Tri Rapide

Juste pour pile sur le sujet. Normalement, si vous trier les chaînes avec les chiffres, vous obtiendrez quelque chose comme ceci:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Mais vous voulez vraiment qu'il puisse reconnaître les valeurs numériques et être classés comme

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Voici comment le faire...

Note:

• J'ai volé le Tri Rapide de l'internet, il y a longtemps, vous ne savez pas où maintenant...
• J'ai traduit le CompareNaturalNum fonction de ce qui a été écrit à l'origine dans C à partir de l'internet aussi bien.
• Différence avec d'autres Q-Trie: je n'ai pas de swap de ces valeurs si le BottomTemp = TopTemp

Nombre Naturel Tri Rapide

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

Nombre naturel de Comparer(Utilisé dans la fonction de Tri Rapide)

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

appel isdigit(Utilisé dans CompareNaturalNum)

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

Answer 5

J'ai posté un peu de code en réponse à une question sur StackOverflow:

Tri d'une multidimensionnal tableau en VBA

Les exemples de code dans ce thread comprennent:

1. Un tableau de vecteurs Quicksort;
2. Un multi-colonne de la matrice de QuickSort;
3. Un BubbleSort.

Alain optimisée de Quicksort est très brillant: j'ai juste fait une base de split-et-recurse, mais l'exemple de code ci-dessus a un "déclenchement" fonction qui coupe vers le bas sur redondante des comparaisons de valeurs dupliquées. D'autre part, j'ai le code pour Excel, et il y a un peu plus dans le sens de la défense de codage - être averti, vous en aurez besoin si votre tableau contient le pernicieuse " Empty()' variante, qui va briser votre While... Wend opérateurs de comparaison et de piéger votre code dans une boucle infinie.

Notez que quicksort algorthms - et tout algorithme récursif - peut remplir la pile et de crash Excel. Si votre matrice a moins de 1024 membres, j'aimerais utiliser un rudimentaire BubbleSort.

Public Sub QuickSortArray(ByRef SortArray Comme Variante, _ En option lngMin Tant = -1, _ En option lngMax Tant = -1, _ En option lngColumn Tant = 0) On Error Resume Next

"Trier un tableau en 2 Dimensions

'SampleUsage: tri arrData par le contenu de la colonne 3 ' 'QuickSortArray arrData, , , 3

' 'Posté par Jim Rech 10/20/98 Excel.Programmation

'Modifications, Nigel Heffernan:

'"Échapper échec de la comparaison avec vide variante 'La" défense de codage: vérifier l'état des entrées

Dim i as Long Dim j as Long Dim varMid Comme Variante Dim arrRowTemp Comme Variante Dim lngColTemp Tant

If IsEmpty(SortArray) Puis Exit Sub Fin De Si

Si InStr(TypeName(SortArray), "()") < 1 then 'IsArray() est un peu cassé: recherchez les parenthèses dans le nom du type Exit Sub Fin De Si

Si lngMin = -1, Alors lngMin = LBound(SortArray, 1) Fin De Si

Si lngMax = -1, Alors lngMax = UBound(SortArray, 1) Fin De Si

Si lngMin >= lngMax Puis " pas de tri nécessaire Exit Sub Fin De Si

i = lngMin j = lngMax

varMid = Vide varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

'Nous envoyer le "Vide", et des données non valides éléments à la fin de la liste: Si IsObject(varMid) Puis ' noter que nous n'avons pas vérifier isObject(SortArray(n)) - varMid peut ramasser valides par défaut un membre ou une propriété i = lngMax j = lngMin Sinon si Estvide(varMid) Puis i = lngMax j = lngMin ElseIf IsNull(varMid) Puis i = lngMax j = lngMin ElseIf varMid = "" Then i = lngMax j = lngMin ElseIf varType(varMid) = vbError Alors i = lngMax j = lngMin ElseIf varType(varMid) > 17 i = lngMax j = lngMin Fin De Si

While i <= j

 While SortArray(i, lngColumn) < varMid And i < lngMax
     i = i + 1
 Wend

 While varMid < SortArray(j, lngColumn) And j > lngMin
     j = j - 1
 Wend


 If i <= j Then

     ' Swap the rows
     ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
     For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
         arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
         SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
         SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
     Next lngColTemp
     Erase arrRowTemp

     i = i + 1
     j = j - 1

 End If

Wend

Si (lngMin < j) Puis d'Appeler QuickSortArray(SortArray, lngMin, j, lngColumn) Si (i < lngMax) Puis d'Appeler QuickSortArray(SortArray, j', lngMax, lngColumn)

End Sub