none
algorithme de tri super optimisé RRS feed

  • Question

  • Bonjour j'aimerais savoir si certains auraient le code vba d'un algorithme de tri optimisé (jusqu'à 1 000 000 éléments double dans un tableau)

    en fait celui qui est derrière excel est très efficace mais j'ai du mal à l'appliquer dans le corps de mon dev vba et les algorithmes simples que j'ai trouvé dans la littératures sont vraiment trop lents

    merci d'avance pour vos contributions et joyeuses fêtes à tous!

    Julien

    • Déplacé Ciprian Duduiala vendredi 23 décembre 2011 16:45 (Origine :Visual Basic)
    jeudi 22 décembre 2011 21:19

Réponses

  • Bonjour,

     

    Vous pouvez essayer ce code:

    Il faut définir dans une module standard:

    Public Enum Ordre                   'Ordre de classement
        Croissant = 1
        Décroissant
    End Enum

    Function QuickSort(Tableau() As Variant, Optional Sens As Ordre = Ordre.Croissant)
    Dim MaxVal As Variant
    Dim MaxIndex As Integer
    Dim i, j As Integer
    
    Select Case Sens
        Case Ordre.Croissant
            'Examinons tous les éléments du tableau en commençant par le dernier
            For i = UBound(Tableau) To 1 Step -1
                'Affectons à MaxVal la valeur de cet élément
                'et l'index de cet élément à MaxIndex
                MaxVal = Tableau(i)
                MaxIndex = i
                'Passons en revue chacun des autres éléments du tableau
                'pour voir s'il y en a des plus grands que MaxVal.
                'Si tel est le cas, alors cet élément devient le nouveau MaxVal
                For j = 1 To i
                    If Tableau(j) > MaxVal Then
                        MaxVal = Tableau(j)
                        MaxIndex = j
                    End If
                Next j
                'Si l'index du plus grand élément n'est pas i, alors
                'échangeons cet élément avec l'élément i.
                If MaxIndex < i Then
                    Tableau(MaxIndex) = Tableau(i)
                    Tableau(i) = MaxVal
                End If
            Next i
        Case Ordre.Décroissant
            Dim MinVal As Variant
            Dim MinIndex As Integer
            
            'Examinons tous les éléments du tableau en commençant par le dernier
            For i = UBound(Tableau) To 1 Step -1
                'Affectons à MinVal la valeur de cet élément
                'et l'index de cet élément à MinIndex
                MinVal = Tableau(i)
                MinIndex = i
                'Passons en revue chacun des autres éléments du tableau
                'pour voir s'il y en a des plus petits que MinVal.
                'Si tel est le cas, alors cet élément devient le nouveau MinVal
                For j = 1 To i
                    If Tableau(j) < MinVal Then
                        MinVal = Tableau(j)
                        MinIndex = j
                    End If
                Next j
                'Si l'index du plus petit élément n'est pas i, alors
                'échangeons cet élément avec l'élément i.
                If MinIndex < i Then
                    Tableau(MinIndex) = Tableau(i)
                    Tableau(i) = MinVal
                End If
            Next i
    End Select
    
    End Function
    

    samedi 24 décembre 2011 04:19
  • Bonjour,

    Il y a surtout ce code, théoriquement le plus rapide (un peu plus de 2 secondes pour 1.000.000 !).  Lancez la procédure "Test" pour essayer.

    Cdt,

    Blaise

    Option Explicit
    Option Compare Text


    Sub Test()
        Dim Tableau(1 To 1000000) As Double
        Dim I As Long
        Randomize Timer
        For I = 1 To UBound(Tableau)
            Tableau(I) = Rnd() * 1000000000
        Next
        Debug.Print Timer
        Tri_Idx Tableau()
        Debug.Print Timer
        For I = 1 To 100
            Debug.Print Tableau(I),
        Next
    End Sub

    Public Sub Tri_Idx(Idx1() As Double)
        '---------------------------------------------------------------------------------------
        ' Procedure : Tri_Idx
        ' Sujet     : tri rapide récursif, procédure d'appel
        '---------------------------------------------------------------------------------------
        '
        'ATTENTION : pour le bien,  Option Compare Text si comparaison de texte
        '
        Call Tri_idx_R(Idx1(), LBound(Idx1), UBound(Idx1))    'Proc récursive
    End Sub

    Private Sub Tri_idx_R(Idx2() As Double, inLow As Long, inHi As Long)
        '---------------------------------------------------------------------------------------
        ' Procedure : Tri_idx_R
        ' Sujet     : procédure de tri récursive
        '---------------------------------------------------------------------------------------
        '
        Dim dblPivot As Double
        Dim tmpSwap As Double
        Dim tmpLow As Long, tmpHi As Long

        tmpLow = inLow
        tmpHi = inHi
        dblPivot = Idx2((inLow + inHi) \ 2)
        While (tmpLow <= tmpHi)
            While (Idx2(tmpLow) < dblPivot And tmpLow < inHi)
                tmpLow = tmpLow + 1
            Wend
            While (dblPivot < Idx2(tmpHi) And tmpHi > inLow)
                tmpHi = tmpHi - 1
            Wend
            If (tmpLow <= tmpHi) Then
                tmpSwap = Idx2(tmpLow)
                Idx2(tmpLow) = Idx2(tmpHi)
                Idx2(tmpHi) = tmpSwap
                tmpLow = tmpLow + 1
                tmpHi = tmpHi - 1
            End If
        Wend
        ' recursive call
        If (inLow < tmpHi) Then Tri_idx_R Idx2, inLow, tmpHi
        If (tmpLow < inHi) Then Tri_idx_R Idx2, tmpLow, inHi
    End Sub

    mardi 3 janvier 2012 11:04

Toutes les réponses

  • Bonjour,

     

    Je vous conseil de mettre votre message dans http://social.msdn.microsoft.com/Forums/fr-FR/vbafr/threads

     


    Cordialement,
    Xavier TALOUR
    Alias Troxsa SendMail
    Voir le profil de Xavier TALOUR sur LinkedIn

    • Modifié Troxsa vendredi 23 décembre 2011 16:57
    vendredi 23 décembre 2011 08:34
  • Bonjour,

     

    Vous pouvez essayer ce code:

    Il faut définir dans une module standard:

    Public Enum Ordre                   'Ordre de classement
        Croissant = 1
        Décroissant
    End Enum

    Function QuickSort(Tableau() As Variant, Optional Sens As Ordre = Ordre.Croissant)
    Dim MaxVal As Variant
    Dim MaxIndex As Integer
    Dim i, j As Integer
    
    Select Case Sens
        Case Ordre.Croissant
            'Examinons tous les éléments du tableau en commençant par le dernier
            For i = UBound(Tableau) To 1 Step -1
                'Affectons à MaxVal la valeur de cet élément
                'et l'index de cet élément à MaxIndex
                MaxVal = Tableau(i)
                MaxIndex = i
                'Passons en revue chacun des autres éléments du tableau
                'pour voir s'il y en a des plus grands que MaxVal.
                'Si tel est le cas, alors cet élément devient le nouveau MaxVal
                For j = 1 To i
                    If Tableau(j) > MaxVal Then
                        MaxVal = Tableau(j)
                        MaxIndex = j
                    End If
                Next j
                'Si l'index du plus grand élément n'est pas i, alors
                'échangeons cet élément avec l'élément i.
                If MaxIndex < i Then
                    Tableau(MaxIndex) = Tableau(i)
                    Tableau(i) = MaxVal
                End If
            Next i
        Case Ordre.Décroissant
            Dim MinVal As Variant
            Dim MinIndex As Integer
            
            'Examinons tous les éléments du tableau en commençant par le dernier
            For i = UBound(Tableau) To 1 Step -1
                'Affectons à MinVal la valeur de cet élément
                'et l'index de cet élément à MinIndex
                MinVal = Tableau(i)
                MinIndex = i
                'Passons en revue chacun des autres éléments du tableau
                'pour voir s'il y en a des plus petits que MinVal.
                'Si tel est le cas, alors cet élément devient le nouveau MinVal
                For j = 1 To i
                    If Tableau(j) < MinVal Then
                        MinVal = Tableau(j)
                        MinIndex = j
                    End If
                Next j
                'Si l'index du plus petit élément n'est pas i, alors
                'échangeons cet élément avec l'élément i.
                If MinIndex < i Then
                    Tableau(MinIndex) = Tableau(i)
                    Tableau(i) = MinVal
                End If
            Next i
    End Select
    
    End Function
    

    samedi 24 décembre 2011 04:19
  • Bonjour, Julien,

     

    Est-ce que vous avez testé la solution proposée par Archampi ? Merci de tenir la communauté informée sur la suite de vos démarches.

     

    Cordialement,

     

    Cipri


    Suivez MSDN sur Twitter   Suivez MSDN sur Facebook


    Ciprian DUDUIALA, MSFT  
    •Nous vous prions de considérer que dans le cadre de ce forum on n’offre pas de support technique et aucune garantie de la part de Microsoft ne peut être offerte.

    mardi 3 janvier 2012 11:03
  • Bonjour,

    Il y a surtout ce code, théoriquement le plus rapide (un peu plus de 2 secondes pour 1.000.000 !).  Lancez la procédure "Test" pour essayer.

    Cdt,

    Blaise

    Option Explicit
    Option Compare Text


    Sub Test()
        Dim Tableau(1 To 1000000) As Double
        Dim I As Long
        Randomize Timer
        For I = 1 To UBound(Tableau)
            Tableau(I) = Rnd() * 1000000000
        Next
        Debug.Print Timer
        Tri_Idx Tableau()
        Debug.Print Timer
        For I = 1 To 100
            Debug.Print Tableau(I),
        Next
    End Sub

    Public Sub Tri_Idx(Idx1() As Double)
        '---------------------------------------------------------------------------------------
        ' Procedure : Tri_Idx
        ' Sujet     : tri rapide récursif, procédure d'appel
        '---------------------------------------------------------------------------------------
        '
        'ATTENTION : pour le bien,  Option Compare Text si comparaison de texte
        '
        Call Tri_idx_R(Idx1(), LBound(Idx1), UBound(Idx1))    'Proc récursive
    End Sub

    Private Sub Tri_idx_R(Idx2() As Double, inLow As Long, inHi As Long)
        '---------------------------------------------------------------------------------------
        ' Procedure : Tri_idx_R
        ' Sujet     : procédure de tri récursive
        '---------------------------------------------------------------------------------------
        '
        Dim dblPivot As Double
        Dim tmpSwap As Double
        Dim tmpLow As Long, tmpHi As Long

        tmpLow = inLow
        tmpHi = inHi
        dblPivot = Idx2((inLow + inHi) \ 2)
        While (tmpLow <= tmpHi)
            While (Idx2(tmpLow) < dblPivot And tmpLow < inHi)
                tmpLow = tmpLow + 1
            Wend
            While (dblPivot < Idx2(tmpHi) And tmpHi > inLow)
                tmpHi = tmpHi - 1
            Wend
            If (tmpLow <= tmpHi) Then
                tmpSwap = Idx2(tmpLow)
                Idx2(tmpLow) = Idx2(tmpHi)
                Idx2(tmpHi) = tmpSwap
                tmpLow = tmpLow + 1
                tmpHi = tmpHi - 1
            End If
        Wend
        ' recursive call
        If (inLow < tmpHi) Then Tri_idx_R Idx2, inLow, tmpHi
        If (tmpLow < inHi) Then Tri_idx_R Idx2, tmpLow, inHi
    End Sub

    mardi 3 janvier 2012 11:04
  • Quelles difficultés rencontres-tu, lorsque tu veux intégrer la fonctionalité de tri d'Excel dans ta procédure?
    mardi 3 janvier 2012 11:32