Trier un tableau virtuel en VBA

[chatounet]

Bonjour à vous,
Tout est dans le titre. j'ai créé un tableau sous VBA tabl() de 2 colonnes l'une contenant des dates, l'autre un nombre. Je voudrais trier ce tableau par dates et par ordre croissant.

En fouillant dans le net j'ai trouvé une possibilité Quick sort que je n'arrive pas à adapter. Mais peu importe la solution tant qu'elle fonctionne.

Si vous pouviez me tirer cette épine, j'en serais très soulagé.

J'ai joint un classeur avec, je pense, ce dont vous aurez besoin.

En vous remerciant pour votre attention.

 

[vgendron]

Hello

juste un site à aller voir: section tableau - Tri QuickSort d'un tableau à deux dimensions

http://boisgontierjacques.free.fr/

 

[chatounet]

Merci pour ta réponse Vgendron, j'ai vu ce programme, mais je n'arrive pas à l'adapter dans ma macro.
Si tu sais faire et que tu peux me le faire, je suis preneur ; cela me permettrait sûrement de mieux le comprendre pour pouvoir le réutiliser..
Cordialement et merci encore

 

[job75]

Bonjour chatounet, vgendron,

Avant de se lancer dans les tableaux VBA il me paraît judicieux d'utiliser les outils classiques d'Excel.

C'est à dire ici le filtre automatique et le tri, par cette macro assez simple :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim filtre As Range, dest As Range, n&
Set filtre = [I1] 'à adapter
Set dest = [H3] 'à adapter
If Intersect(Target, filtre) Is Nothing Then Exit Sub
With [A1].CurrentRegion.Resize(, 6)
    n = Application.CountIf(.Columns(2), filtre)
    If n Then
        Application.ScreenUpdating = False
        .AutoFilter 2, filtre 'filtre automatique
        .Offset(1).Columns(4).Copy dest(2)
        .Offset(1).Columns(3).Copy dest(2, 2)
        .Offset(1).Columns(6).Copy dest(n + 2)
        .Offset(1).Columns(5).Copy dest(n + 2, 2)
        AutoFilterMode = False 'le filtre est retiré
        dest(2).Resize(2 * n, 2).Sort dest, xlAscending, Header:=xlNo 'tri sur les dates
    End If
End With
dest.Offset(2 * n + 1).Resize(Rows.Count - 2 * n - dest.Row, 2).Delete xlUp 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

L'intérêt de cette méthode c'est que les formats sont conservés, et elle est rapide.

Fichier joint.

A+

 

[chatounet]

Impeccable Job75,
Merci à vous. Vous êtes efficace, et votre proposition me permet d'élargir mon champ de vision et de réflexion.
Merci encore,

 

[Dranreb]

Mon module MGigogne contient une procédure d'indexation (c'est la même chose qu'un classement sauf que ça ne change pas l'ordre du tableau: ça indique quels indices prendre pour le parcourir dans l'ordre). C'est une autre méthode que le Quick-Sort, légèrement plus rapide. Je la propose rarement seule, car en général c'est quand même en fin de compte pour en faire quelque chose, et la fonction Gigogne offre pour cela un service plus aboutit.

 

[job75]

Re, salut Bernard,

Ma solution précédente était un début, voici une solution entièrement par tableaux VBA :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim filtre As Range, dest As Range, n&, t, a(), b(), f$, i&
Set filtre = [I1] 'à adapter
Set dest = [H3] 'à adapter
If Intersect(Target, filtre) Is Nothing Then Exit Sub
With [A1].CurrentRegion.Resize(, 6)
    n = Application.CountIf(.Columns(2), filtre)
    If n Then
        t = .Value 'tableau VBA, plus rapide
        ReDim a(1 To 2 * n): ReDim b(1 To 2 * n) 'tableaux à 1 dimension
        f = filtre 'scalaire, plus rapide
        n = 0
        For i = 2 To UBound(t)
            If t(i, 2) = f Then
                n = n + 1: a(n) = t(i, 4): b(n) = t(i, 3)
                n = n + 1: a(n) = t(i, 6): b(n) = t(i, 5)
            End If
        Next
        tri a, b, 1, n
        ReDim t(1 To n, 1 To 2)
        For i = 1 To n 'transposition
            t(i, 1) = a(i)
            t(i, 2) = b(i)
        Next
        dest(2).Resize(n, 2) = t 'restitution
    End If
End With
dest.Offset(n + 1).Resize(Rows.Count - n - dest.Row, 2).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Sub tri(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, b, g, droi)
If gauc < d Then Call tri(a, b, gauc, d)
End Sub

Bien sûr ici les formats ne sont pas conservés.

Fichier (2).

Edit : pour tester les durées d'exécution j'ai recopié le tableau A2:F6 jusqu'à la ligne 5001 (x1000).

La solution (2) prend moins de 1/10ème de seconde alors que la solution (1) prend 2 secondes.

En effet la copie d'un grand nombre de cellules disjointes prend beaucoup de temps.

A+

 

[BOISGONTIER]

Bonsoir,

Tri d'un Array() multi-colonnes (quick-sort avec choix colonne de tri - réutilisable-).

Option Compare Text
Sub TriParDateArray()
  Set f = Sheets("feuil1")
  Set Rng = f.Range("A2:F" & f.[A65000].End(xlUp).Row)
  Tbl = Rng.Value
  nom = "Schroeder"
  n = Application.CountIf(Rng, nom)
  Dim Tbl2: ReDim Tbl2(1 To n * 2, 1 To 2)
  For i = 1 To UBound(Tbl)
    If Tbl(i, 2) = nom Then
      j = j + 1: Tbl2(j, 1) = Tbl(i, 4): Tbl2(j, 2) = Tbl(i, 3)
      j = j + 1: Tbl2(j, 1) = Tbl(i, 6): Tbl2(j, 2) = Tbl(i, 5)
    End If
  Next i
  Tri Tbl2, 1, 1, UBound(Tbl2)
  '[B10:C13].Value = Tbl2  'vérif
End Sub

Sub Tri(a, ColTri, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2, ColTri)
  g = gauc: d = droi
  Do
    Do While a(g, ColTri) < ref: g = g + 1: Loop
    Do While ref < a(d, ColTri): d = d - 1: Loop
    If g <= d Then
       For k = LBound(a, 2) To UBound(a, 2)
         temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
       Next k
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, ColTri, g, droi)
  If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

http://boisgontierjacques.free.fr/fichiers/Cellules/TriArrayMultiCol.xls


jb

 

[chatounet]

Bonsoir / bojour !!
Que d'émotion pour toutes ces propositions que n'ai pas encore ouvertes, expérimentées, mais je ne pressens que du bonheur.
Merci beaucoup à tous, ça fait chaud au cœur et frais à l'esprit d'avoir des personnes comme vous à mes côtés.
A plus tard, et portez-vous bien.