web-dev-qa-db-fra.com

Fonction de tri de tableau VBA?

Je recherche une sorte d'implémentation décente pour les tableaux dans VBA. Un Quicksort serait préféré. Ou tout autre algorithme de tri autre que bulle ou fusion suffirait.

Veuillez noter que ceci est destiné à fonctionner avec MS Project 2003, vous devez donc éviter les fonctions natives d'Excel et tout élément lié à .net.

arrayssortingvbavb6ms-project
74
Mark Nold

Jetez un oeil ici :
Edit: La source référencée (allexperts.com) a été fermée depuis, mais voici les informations pertinentes auteur commentaires:

Il existe de nombreux algorithmes disponibles sur le Web pour le tri. Le plus polyvalent et généralement le plus rapide est le algorithme Quicksort . Ci-dessous une fonction pour cela.

Appelez-le simplement en passant un tableau de valeurs (chaîne ou numérique; peu importe) avec la limite inférieure du tableau (généralement 0 ) et la limite supérieure du tableau (c'est-à-dire UBound(myArray).)

Exemple : Call QuickSort(myArray, 0, UBound(myArray))

Quand ce sera fait, myArray sera trié et vous pourrez en faire ce que vous voulez.
(Source: archive.org )

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

Notez que cela ne fonctionne qu'avec des tableaux unidimensionnels (ou "normaux"?). (Il existe un tableau multidimensionnel de travail QuickSort ici .)

91
Jorge Ferreira

J'ai converti l'algorithme de «tri rapide» en VBA, si quelqu'un d'autre le souhaite.

Je l'ai optimisé pour fonctionner sur un tableau d'Int/Longs, mais il devrait être simple de le convertir en un tableau qui fonctionne sur des éléments comparables arbitraires.

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
15
Alain

Explication en allemand mais le code est une implémentation en place bien testée:

Private Sub QuickSort(ByRef 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é comme ceci:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))
9
Konrad Rudolph

J'ai posté du code en réponse à une question connexe sur StackOverflow:

Tri d'un tableau multidimensionnel dans VBA

Les exemples de code dans ce fil incluent:

  1. Un tableau de vecteurs Quicksort;
  2. Un tableau multi-colonnes QuickSort;
  3. Un BubbleSort.

Le Quicksort optimisé d'Alain est très brillant: je viens de faire un split-and-recurse basique, mais l'exemple de code ci-dessus a une fonction de «déclenchement» qui réduit les comparaisons redondantes de valeurs dupliquées. Par contre, je code pour Excel, et il y a un peu plus de code défensif - soyez averti, vous en aurez besoin si votre tableau contient la variante pernicieuse 'Empty ()', qui cassera votre While .. Opérateurs de comparaison Wend et capturez votre code dans une boucle infinie.

Notez que les algorithmes de tri rapide - et tout algorithme récursif - peuvent remplir la pile et planter Excel. Si votre groupe compte moins de 1024 membres, j'utiliserais un BubbleSort rudimentaire. 

 Public Sub QuickSortArray (ByRef SortArray As Variant, _ Facultatif lngMin As Long = -1, _ Facultatif lngMax As Long = -1, _ Facultatif lngColumn As Long = 0) En cas d'erreur, reprise suivante
 'Trier un tableau à 2 dimensions
 ' Exemple d'utilisation: triez arrData par le contenu de la colonne 3 ' ' QuickSortArray arrData, 3
' 'Publié par Jim Rech le 20/10/98 Excel.Programming
 'Modifications, Nigel Heffernan:
 ' 'Échapement échec de la comparaison avec la variante vide ' 'Codage défensif: vérifier les entrées
 Dim i As Long Dim j As Long Dim varMid As Variant Dim arrowTemp As Variant Dim lngColTemp As Long

 Si IsEmpty (SortArray) Alors Quitter Sub Fin si
 Si InStr (TypeName (SortArray), "()") <1 Alors 'IsArray () est un peu cassé: recherchez des parenthèses dans le nom du type Quitter Sub Fin si
 Si lngMin = -1 Alors lngMin = LBound (SortArray, 1) Fin si
 Si lngMax = -1 Alors lngMax = UBound (SortArray, 1) Fin si
 Si lngMin> = lngMax Alors, aucun tri requis Quitter Sub Fin si

 i = lngMin j = lngMax
 varMid = Vide varMid = SortArray ((lngMin + lngMax)\2, lngColumn)
 'Nous envoyons les éléments de données' vides 'et non valides à la fin de la liste: Si IsObject (varMid) Then 'notez que nous ne vérifions pas isObject (SortArray (n)) - varMid pourrait choisir un membre ou une propriété par défaut valide i = lngMax j = lngMin ElseIf IsEmpty (varMid) Alors i = lngMax j = lngMin ElseIf IsNull (varMid) Alors i = lngMax j = lngMin ElseIf varMid = "" Alors i = lngMax j = lngMin ElseIf varType (varMid) = vbError Alors, i = lngMax j = lngMin ElseIf varType (varMid)> 17 Puis i = lngMax j = lngMin Fin si

 Alors que je <= j
 While SortArray (i, LngColumn) <varMid Et i <lngMax i = i + 1 Wend
 Alors que varMid <SortArray (j, lngColumn) et j> lngMin j = j - 1 Wend

 Si je <= j alors
 'Échangez les lignes ReDim arrRowTemp (LBound (SortArray, 2) à UBound (SortArray, 2)) Pour lngColTemp = LBound (SortArray, 2) to UBound (SortArray, 2) arrRowTemp (lngColTemp) = SortArray (i, lngColTemp) SortArray (i, lngColTemp) = SortArray (j, lngColTemp) SortArray (j, lngColTemp) = arrRowTemp (lngColTemp) Suivant lngColTemp Effacer arrRowTemp
 i = i + 1 j = j - 1
 Fin si

 Wend
 If (lngMin <j) Ensuite, appelez QuickSortArray (SortArray, LngMin, j, LngColumn) If (i <lngMax) Puis appelez QuickSortArray (SortArray, i, lngMax, lngColumn)

 End Sub

6
Nigel Heffernan

Natural Number (Strings) Tri rapide  

Juste pour empiler sur le sujet. Normalement, si vous triez les chaînes avec des nombres, vous obtiendrez quelque chose comme ceci:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Mais vous voulez vraiment qu'il reconnaisse les valeurs numériques et soit trié comme 

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Voici comment le faire ...

Remarque: 

  • J'ai volé le Quick Sort sur Internet il y a longtemps, je ne sais pas où maintenant ... 
  • J'ai également traduit la fonction CompareNaturalNum qui était à l'origine écrite en C à partir d'Internet.
  • Différence avec les autres Q-Sorts: je n’échange pas les valeurs si 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

Comparaison des nombres naturels (utilisée dans le 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
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    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

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
6
Profex
Dim arr As Object
Dim InputArray

'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")

'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")

'number
'InputArray = Array(6, 5, 3, 4, 2, 1)

' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
Next

'sorting happens
arr.Sort

'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.

sorted_array = arr.toarray
4
Prasand Kumar

Vous ne vouliez pas d'une solution basée sur Excel, mais comme j'avais le même problème aujourd'hui et que je voulais tester d'autres fonctions d'applications Office, j'ai écrit la fonction ci-dessous.

Limites:

  • Matrices bidimensionnelles;
  • maximum de 3 colonnes comme clés de tri;
  • dépend d'Excel;

Testé en appelant Excel 2010 à partir de Visio 2010

Option Base 1


Private Function sort_array_2D_Excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")

'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library

    Dim Excel_application As Excel.Application
    Dim Excel_workbook As Excel.Workbook
    Dim Excel_worksheet As Excel.Worksheet

    Set Excel_application = CreateObject("Excel.Application")

    Excel_application.Visible = True
    Excel_application.ScreenUpdating = False
    Excel_application.WindowState = xlNormal

    Set Excel_workbook = Excel_application.Workbooks.Add
    Excel_workbook.Activate

    Set Excel_worksheet = Excel_workbook.Worksheets.Add
    Excel_worksheet.Activate
    Excel_worksheet.Visible = xlSheetVisible

    Dim Excel_range As Excel.Range
    Set Excel_range = Excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
    Excel_range = array_2D


    For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)

        If IsNumeric(array_sortkeys(i_sortkey)) Then
            sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
            Set array_sortkeys(i_sortkey) = Excel_worksheet.Range(sortkey_range)

        Else
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
            End

        End If

    Next i_sortkey


    For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
        Select Case LCase(array_sortorders(i_sortorder))
            Case "asc"
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
            Case "desc"
                array_sortorders(i_sortorder) = XlSortOrder.xlDescending
            Case Else
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
        End Select
    Next i_sortorder

    Select Case LCase(tag_header)
        Case "yes"
            tag_header = Excel.xlYes
        Case "no"
            tag_header = Excel.xlNo
        Case "guess"
            tag_header = Excel.xlGuess
        Case Else
            tag_header = Excel.xlGuess
    End Select

    Select Case LCase(tag_matchcase)
        Case "true"
            tag_matchcase = True
        Case "false"
            tag_matchcase = False
        Case Else
            tag_matchcase = False
    End Select


    Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
        Case 1
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 2
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 3
            Call Excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
        Case Else
            MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
            End
    End Select


    For i_row = 1 To Excel_range.Rows.Count

        For i_column = 1 To Excel_range.Columns.Count

            array_2D(i_row, i_column) = Excel_range(i_row, i_column)

        Next i_column

    Next i_row


    Excel_workbook.Close False
    Excel_application.Quit

    Set Excel_worksheet = Nothing
    Set Excel_workbook = Nothing
    Set Excel_application = Nothing


    sort_array_2D_Excel = array_2D


End Function

Voici un exemple sur la façon de tester la fonction:

Private Sub test_sort()

    array_unsorted = dim_sort_array()

    Call msgbox_array(array_unsorted)

    array_sorted = sort_array_2D_Excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")

    Call msgbox_array(array_sorted)

End Sub


Private Function dim_sort_array()

    Dim array_unsorted(1 To 5, 1 To 3) As String

    i_row = 0

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    dim_sort_array = array_unsorted

End Function


Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")

    msgbox_string = string_info & vbLf

    For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)

        msgbox_string = msgbox_string & vbLf & i_row & vbTab

        For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)

            msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab

        Next i_column

    Next i_row

    MsgBox msgbox_string

End Sub

Si quelqu'un teste cela avec d'autres versions de office, merci de poster ici s'il y a un problème.

2
lucas0x7B

Je me demande ce que vous diriez à propos de ce code de tri de tableaux. Elle est rapide pour la mise en œuvre et fait le travail… n’a pas encore été testée pour les baies de grande taille. Cela fonctionne pour les tableaux unidimensionnels, pour des valeurs multidimensionnelles supplémentaires, la matrice de repositionnement aurait besoin d'être construite (avec une dimension de moins que le tableau initial).

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
            eValue = eArray(AR1)
            For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
                If eArray(AR2) < eValue Then
                    eArray(AR1) = eArray(AR2)
                    eArray(AR2) = eValue
                    eValue = eArray(AR1)
                End If
            Next AR2
        Next AR1
0
Jarek

Heapsort implémentation. Un O (n log (n)) (moyenne et pire des cas), en place, instable algorithme de tri.

Utiliser avec: Call HeapSort(A), où A est un tableau unidimensionnel de variantes, avec Option Base 1.

Sub SiftUp(A() As Variant, I As Long)
    Dim K As Long, P As Long, S As Variant
    K = I
    While K > 1
        P = K \ 2
        If A(K) > A(P) Then
            S = A(P): A(P) = A(K): A(K) = S
            K = P
        Else
            Exit Sub
        End If
    Wend
End Sub

Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
    Do
        L = K + K
        If L > I Then Exit Sub
        If L + 1 <= I Then
            If A(L + 1) > A(L) Then L = L + 1
        End If
        If A(K) < A(L) Then
            S = A(K): A(K) = A(L): A(L) = S
            K = L
        Else
            Exit Sub
        End If
    Loop
End Sub

Sub HeapSort(A() As Variant)
    Dim N As Long, I As Long, S As Variant
    N = UBound(A)
    For I = 2 To N
        Call SiftUp(A, I)
    Next I
    For I = N To 2 Step -1
        S = A(I): A(I) = A(1): A(1) = S
        Call SiftDown(A, I - 1)
    Next
End Sub
0
Jean-Claude Arbaut

C’est ce que j’utilise pour trier en mémoire: il peut facilement être étendu pour trier un tableau.

Sub sortlist()

    Dim xarr As Variant
    Dim yarr As Variant
    Dim zarr As Variant

    xarr = Sheets("sheet").Range("sing col range")
    ReDim yarr(1 To UBound(xarr), 1 To 1)
    ReDim zarr(1 To UBound(xarr), 1 To 1)

    For n = 1 To UBound(xarr)
        zarr(n, 1) = 1
    Next n

    For n = 1 To UBound(xarr) - 1
        y = zarr(n, 1)
        For a = n + 1 To UBound(xarr)
            If xarr(n, 1) > xarr(a, 1) Then
                y = y + 1
            Else
                zarr(a, 1) = zarr(a, 1) + 1
            End If
        Next a
        yarr(y, 1) = xarr(n, 1)
    Next n

    y = zarr(UBound(xarr), 1)
    yarr(y, 1) = xarr(UBound(xarr), 1)

    yrng = "A1:A" & UBound(yarr)
    Sheets("sheet").Range(yrng) = yarr

End Sub
0
Reged

Je pense que mon code (testé) est plus "éduqué", en supposant que plus simple mieux c'est .

Option Base 1

'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
    Dim check As Boolean
    check = True
    If IsNull(Rango) Then
        check = False
    End If
    If check Then
        Application.Volatile
        Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
        n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
        ReDim x(n, m)
        For i = 1 To n Step 1
            For j = 1 To m Step 1
                x(i, j) = Application.Large(Rango, k)
                k = k - 1
            Next j
        Next i
        SORT = x
    Else
        Exit Function
    End If
End Function
0
Moreno