web-dev-qa-db-fra.com

Tri d'un tableau multidimensionnel dans VBA

J'ai défini le tableau suivant Dim myArray(10,5) as Long et souhaite le trier. Quelle serait la meilleure méthode pour le faire?

Je devrai gérer beaucoup de données, comme une matrice 1000 x 5. Il contient principalement des nombres et des dates et doit être trié selon une certaine colonne.

arraysvbasorting
10
BlackLabrador

Voici un QuickSort multi-colonnes et un seul colonne pour VBA, modifié à partir d'un exemple de code envoyé par Jim Rech sur Usenet.

Remarques: 

Vous remarquerez que je fais un lot codage plus défensif que ce que vous verrez dans la plupart des exemples de code disponibles sur le Web: ceci est un forum Excel, et vous devez anticiper les valeurs nulles et valeurs vides ... Ou tableaux et objets imbriqués dans des tableaux si votre tableau source provient d'une source de données de marché en temps réel tierce partie.

Les valeurs vides et les éléments non valides sont envoyés à la fin de la liste.

Votre appel sera: 

Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
    On Error Resume Next

    'Sort a 2-Dimensional array

    ' SampleUsage: sort arrData by the contents of column 3
    '
    '   QuickSortArray arrData, , , 3

    '
    'Posted by Jim Rech 10/20/98 Excel.Programming

    'Modifications, Nigel Heffernan:

    '       ' Escape failed comparison with empty variant
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrRowTemp As Variant
    Dim lngColTemp As Long

    If IsEmpty(SortArray) Then
        Exit Sub
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Sub
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray, 1)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray, 1)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Sub
    End If

    i = lngMin
    j = lngMax

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

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) = vbError Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) > 17 Then
        i = lngMax
        j = lngMin
    End If

    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

    If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
    If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)

End Sub

... Et la version tableau à colonne unique:

Public Sub QuickSortVector(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1)
    On Error Resume Next

    'Sort a 1-Dimensional array

    ' SampleUsage: sort arrData
    '
    '   QuickSortVector arrData

    '
    ' Originally posted by Jim Rech 10/20/98 Excel.Programming


    ' Modifications, Nigel Heffernan:
    '       ' Escape failed comparison with an empty variant in the array
    '       ' Defensive coding: check inputs

    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim varX As Variant

    If IsEmpty(SortArray) Then
        Exit Sub
    End If
    If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken: Look for brackets in the type name
        Exit Sub
    End If
    If lngMin = -1 Then
        lngMin = LBound(SortArray)
    End If
    If lngMax = -1 Then
        lngMax = UBound(SortArray)
    End If
    If lngMin >= lngMax Then    ' no sorting required
        Exit Sub
    End If

    i = lngMin
    j = lngMax

    varMid = Empty
    varMid = SortArray((lngMin + lngMax) \ 2)

    ' We  send 'Empty' and invalid data items to the end of the list:
    If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a default member or property
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) = vbError Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) > 17 Then
        i = lngMax
        j = lngMin
    End If

    While i <= j

        While SortArray(i) < varMid And i < lngMax
            i = i + 1
        Wend
        While varMid < SortArray(j) And j > lngMin
            j = j - 1
        Wend

        If i <= j Then
            ' Swap the item
            varX = SortArray(i)
            SortArray(i) = SortArray(j)
            SortArray(j) = varX

            i = i + 1
            j = j - 1
        End If

    Wend

    If (lngMin < j) Then Call QuickSortVector(SortArray, lngMin, j)
    If (i < lngMax) Then Call QuickSortVector(SortArray, i, lngMax)

End Sub

J'avais l'habitude d'utiliser BubbleSort pour ce genre de choses, mais cela ralentit sérieusement lorsque le tableau dépasse 1024 lignes. J'inclus le code ci-dessous pour votre référence: veuillez noter que je n'ai pas fourni de code source pour ArrayDimensions, cela ne compilera donc pas pour vous à moins que vous ne le refactériiez - ou que vous le scindiez en versions "Array" et "vector".

 
 
 Public Sub BubbleSort (ByRef InputArray, SortColumn facultatif en tant qu'entier = 0, Optionnel décroissant en tant que booléen = False) 
 'Trier un 1 ou 2 dimensions array. 
 
 
 Dim iFirstRow en tant qu'entier 
 Dim iLastRow en tant qu'entier 
 Dim iFirstCol en tant qu'entier 
 Dim iLastCol en tant qu'entier 
 Dim i As Entier 
 Dim j As Integer 
 Dim k As Integer 
 Dim varTemp As Variant 
 Dim OutputArray As Variant 
 
 Dim iDimensions As Integer 
 
 
 
 IDimensions = ArrayDimensions (InputArray) 
 
 Sélectionnez Case iDimensions 
 Cas 1 
 
 IFirstRow = LBound (InputArray) 
 ILastRow = UBound (InputArray) 
 
 Pour i = iFirstRow à iLastRow - 1. ____.] Pour j = i + 1 Vers iLastRow 
 Si InputArray (i)> InputArray (j) Alors 
 VarTemp = InputArray (j) 
 InputArray (j) = InputArray (i) 
 InputArray (i) = varTemp 
 Fin Si 
 Suivant j 
 Suivant i 
 
 Cas 2 
 
 IFirstRow = LBound (InputArray, 1) 
 ILastRow = UBound (InputArray, 1) 
 
 IFirstCol = LBound (InputArray) , 2) 
 ILastCol = UBound (InputArray, 2) 
 
 Si SortColumn InputArray (j, SortColumn) Alors, 
 Pour k = iFirstCol à iLastCol 
 varTemp = InputArray (j, k) 
 InputArray (j, k) = InputArray (i, k) 
 InputArray (i, k) = varTemp 
 Suivant k 
 Fin Si 
 Suivant j 
 Suivant i 
 
 Fin Sélectionner 
 
 
 Si décroissant puis 
 
 OutputArray = InputArray 
 
 Pour i = LBound (I nputArray, 1) à UBound (InputArray, 1) 
 
 k = 1 + UBound (InputArray, 1) - i 
 Pour j = LBound (InputArray, 2) à UBound ( InputArray, 2) 
 InputArray (i, j) = Tableau de sortie (k, j) 
 Suivant j 
 Suivant i 
 
 Effacer le tableau de sortie. ____.] 
 Fin Si 
 
 
 Fin Sub

Cette réponse est peut-être arrivée un peu tard pour résoudre votre problème lorsque vous en aviez besoin, mais d'autres personnes la saisiront lorsqu'elles rechercheront des réponses à des problèmes similaires.

22
Nigel Heffernan

Le plus difficile est que VBA ne fournit aucun moyen simple d’échanger des lignes dans un tableau 2D. Pour chaque échange, vous devrez boucler 5 éléments et les échanger, ce qui sera très inefficace.

Je suppose qu’un tableau 2D n’est vraiment pas ce que vous devriez utiliser de toute façon. Chaque colonne a-t-elle une signification spécifique? Si tel est le cas, ne devriez-vous pas utiliser un tableau d'un type défini par l'utilisateur ou un tableau d'objets qui sont des instances d'un module de classe? Même si les 5 colonnes n'ont pas de signification particulière, vous pouvez toujours le faire, mais définissez l'UDT ou le module de classe pour n'avoir qu'un seul membre qui est un tableau à 5 éléments.

Pour l’algorithme de tri lui-même, j’utiliserais un tri simple par insertion. 1000 éléments, ce n'est pas très gros, et vous ne remarquerez probablement pas la différence entre un tri par insertion et un tri rapide, tant que nous nous sommes assurés que chaque permutation ne sera pas trop lente. Si vous do utilisez un tri rapide, vous devrez le coder avec soin pour vous assurer de ne pas manquer d'espace dans la pile, ce qui peut être fait, mais c'est compliqué et le tri rapide est assez compliqué. déjà.

Donc, en supposant que vous utilisiez un tableau d'UDT, et en supposant que l'UDT contienne des variantes nommées Field1 à Field5, et en supposant que nous voulions trier sur Field2 (par exemple), le code pourrait ressembler à ceci ...

Type MyType
    Field1 As Variant
    Field2 As Variant
    Field3 As Variant
    Field4 As Variant
    Field5 As Variant
End Type

Sub SortMyDataByField2(ByRef Data() As MyType)
    Dim FirstIdx as Long, LastIdx as Long
    FirstIdx = LBound(Data)
    LastIdx = UBound(Data)

    Dim I as Long, J as Long, Temp As MyType
    For I=FirstIdx to LastIdx-1
        For J=I+1 to LastIdx
            If Data(I).Field2 > Data(J).Field2 Then
                Temp = Data(I)
                Data(I) = Data(J)
                Data(J) = Temp
            End If
        Next J
    Next I
End Sub
8
Steve Jorgensen

parfois, la réponse la plus sereine est la meilleure.

  1. ajouter une feuille vierge
  2. téléchargez votre tableau sur cette feuille
  3. ajouter les champs de tri
  4. appliquer le genre
  5. re-télécharger les données de la feuille dans votre tableau ce sera la même dimension
  6. supprimer la feuille

tadaa. vous ne gagnerez aucun prix de programmation, mais le travail sera fait rapidement.

1
swyx

Pour ce que ça vaut (je ne peux pas montrer le code à ce stade ... laissez-moi voir si je peux le modifier pour le poster), j'ai créé un tableau d'objets personnalisés (afin que chacune des propriétés soit livrée avec l'élément sélectionné.) , a rempli un ensemble de cellules avec les propriétés d’intérêt de chaque élément, puis a utilisé la fonction de tri Excel via vba pour trier la colonne. Je suis sûr qu'il existe probablement un moyen plus efficace de le trier, plutôt que de l'exporter dans des cellules, je ne l'ai pas encore compris. Cela m’a beaucoup aidé, car lorsque j’ai eu besoin d’ajouter une dimension, j’ai simplement ajouté une propriété let and get pour la prochaine dimension du tableau.

0
Dan

Vous pouvez faire un tableau séparé avec 2 colonnes. La colonne 1 serait ce que votre tri sur et 2 est ce que la ligne est dans un autre tableau. Triez ce tableau par colonne 1 (ne changez que les deux colonnes lors de l'échange). Ensuite, vous pouvez utiliser les 2 baies pour traiter les données si nécessaire. D'énormes baies pourraient vous donner des problèmes de mémoire

0
BumKneesOhYeah

Je vais proposer un code légèrement différent de l'approche de Steve.

Tous les points valables sur l'efficacité, mais pour être franc… quand je cherchais une solution, je pouvais me soucier moins de l'efficacité. Son VBA ... Je le traite comme il le mérite. 

Vous voulez trier un tableau 2-d. Tri simple, sale, simple, qui accepte un tableau de taille variable et le trie sur une colonne sélectionnée.

Sub sort_2d_array(ByRef arrayin As Variant, colid As Integer)
'theWidth = LBound(arrayin, 2) - UBound(arrayin, 2)
For i = LBound(arrayin, 1) To UBound(arrayin, 1)
    searchVar = arrayin(i, colid)
    For ii = LBound(arrayin, 1) To UBound(arrayin, 1)
        compareVar = arrayin(ii, colid)
        If (CInt(searchVar) > CInt(compareVar)) Then
            For jj = LBound(arrayin, 2) To UBound(arrayin, 2)
                larger1 = arrayin(i, jj)
                smaller1 = arrayin(ii, jj)
                arrayin(i, jj) = smaller1
                arrayin(ii, jj) = larger1
            Next jj
            i = LBound(arrayin, 1)
            searchVar = arrayin(i, colid)
        End If
        Next ii
    Next i
End Sub
0
giveemheller