Trier un tableau sur VBA

Bonjour,

J'aimerais faire un programme VBA qui me permette de trier des données, puis de faire un classement, puis faire un tri différent pour ensuite avoir le résultat du classement. Le classement peut évoluer en fonction du résultats des autres individus, donc il faut faire 6 boucles pour arriver au classement définitif.

J'ai essayé de le faire et je pense que le programme est écrit à peu près correctement, mais le temps d'exécution est extrêmement long (je n'ai pas pu atteindre la fin de l'exécution, mais c'est au-delà de 24 h...). Le fichier fait 151828 lignes.

Apparemment faire des tableaux() dans VBA permettrait de gagner beaucoup de temps, mais je n'arrive pas à faire un classement du tableau, je suis débutant et j'avoue que c'est trop difficile pour moi à l'heure actuelle...

Voici le programme que j'ai fait (sans utiliser de tableaux):

Sub Macro1()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Range("BI2:BJ151828").Delete

For h = 1 To 6                'LES 6 BOUCLES NÉCESSAIRES
For i = 1 To 151828           'ITÉRATION POUR CHAQUE LIGNE
Range("A2:BJ151828").Sort key1:=Range("AD2"), order1:=xlAscending, key2:=Range("L2"), order2:=xlDescending       '1ER TRI

If Cells(i, 30) = Cells(i + 1, 30) Then                                      'CLASSEMENT
Cells(i + 1, 61) = Cells(i, 61) + 1 
ElseIf Cells(i, 30) <> Cells(i + 1, 30) Then
Cells(i + 1, 61) = 1
Else: Cells(i, 61) = "Erreur"
End If

Range("A2:BJ151828").Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("AM2"), order2:=xlAscending      '2E TRI

If Cells(i, 39) = 1 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A1"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 1 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A1"

ElseIf Cells(i, 39) = 2 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A2"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 2 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A2"

ElseIf Cells(i, 39) = 3 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A3"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 3 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A3"

ElseIf Cells(i, 39) = 4 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A4"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 4 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A4"

ElseIf Cells(i, 39) = 5 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A5"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 5 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A5"

ElseIf Cells(i, 39) = 6 And Cells(i, 1) = Cells(i + 1, 1) And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A6"
Rows(i + 1).Delete
ElseIf Cells(i, 39) = 6 And Cells(i, 61) <= Cells(i, 58) Then
Cells(i, 62) = "A6"
Else

End If

Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Pourriez-vous m'indiquer comment faire ce tri avec un tableau ? Apparemment il n'existe pas de fonction type, il faudrait la créer et c'est là que je coince... pour le reste du programme je devrais pouvoir y arriver.

Merci d'avance

Salut Denis,

Sans les données c'est compliqué de voir ce que fais ton code et donc s'il est améliorable.

Peux tu nous fournir un fichier ?

Girodo,

Bonjour, et bienvenue,

J'aimerais faire un programme VBA qui me permette de trier des données, puis de faire un classement, puis faire un tri différent pour ensuite avoir le résultat du classement. Le classement peut évoluer en fonction du résultats des autres individus, donc il faut faire 6 boucles pour arriver au classement définitif.

Bonjour Girodo, tu as raison ... https://forum.excel-pratique.com/viewtopic.php?f=2&t=13

Et puis cela me parait bien compliqué ! donne nous l'objectif avant de spécifier la méthode.

Car un classement, on peut le faire sans trier, comme ici ... et sans macro.

https://forum.excel-pratique.com/viewtopic.php?f=2&t=130856

75classement.xlsx (32.57 Ko)

Merci de vos réponses.

Je ne peux pas vous envoyer le fichier tel quel pour des raisons de confidentialité, mais je vous envoie la structure type du fichier, avec des données d'exemple.

81essai-vba.xltm (918.24 Ko)

ok merci pour le fichier,

mais peux-tu décrire avec des "mots" comment s'effectue le classement ?

Pour vous aider à comprendre la logique, je vais prendre l'exemple d'une mutation de fonctionnaire : chaque fonctionnaire ("individu") désirant changer de poste indique ses choix d'affectation de préférence ("zones"). Il peut choisir 6 zones différentes, qu'il classe de 1 à 6 ("N°"). Pour départager 2 fonctionnaires qui font le même choix, on tient compte du barème ("points").

Exemple :

  • un fonctionnaire A demande Paris sur son choix n°6 et a 100 points
  • un fonctionnaire B demande Paris sur son choix n°1 et a 50 points
Ici, le fonctionnaire A sera prioritaire pour Paris par rapport au fonctionnaire B puisque son nombre de points est plus élevé.

Chaque zone a un nombre de places déterminées. Dans l'exemple, si Paris n'a qu'une seule place, le fonctionnaire B ne sera pas affecté sur Paris, sauf par exemple si le fonctionnaire A arrive a obtenir un autre choix de rang supérieur, auquel cas A libérera la place de Paris et B pourra la prendre.

Si le fonctionnaire B est pris sur son choix n°1, il pourra lui-même laisser la place où il était prioritaire sur Amiens pour le fonctionnaire C qui avait 20 points, et ainsi de suite...

J'ai donc pensé qu'il fallait :

1/ trier la feuille de calcul en fonction des zones et des points (du plus grand au plus petit)

2/ Appliquer un classement pour chaque zone en fonction des points

3/ Trier la feuille de calcul en fonction des individus et des N° de choix (du plus petit au plus grand)

4/ Indiquer la zone où le choix satisfait est le plus élevé (exemple : A1 pour un choix n°1 satisfait, A2 pour un choix n°2 satisfait...), et supprimer les autres zones de rang inférieur choisit par le même individu pour laisser la place aux autres.

5/ Refaire 5 autres fois la même procédure puisqu'il y a 6 choix possibles.

C'est plus clair pour moi (j'espère pour d'autres aussi).

Je vais reprendre le sujet ! J'espère que Girodo aussi (voire d'autres).

Je reprends ... pourquoi un individu n'a-t-il pas le même nombre de points sur toutes les lignes le concernant ?

C'est normal, si je continue mon exemple des fonctionnaires, on peut supposer qu'il a le droit à des points supplémentaires s'il demande la Martinique puisqu'il est originaire de ce département, par rapport à sa demande sur Paris.

Bon, ok, cela va me permettre de poursuivre la réflexion.

Il est clair qu'on fait un choix en fonction des demandes et des points, tant pis si tout n'est pas optimisé et qu'il reste des employés non affectés et des choix non pourvus.

J'ai vu aussi que le nombre de places est bien dépendant de la zone. Heureusement sinon je ne comprenait plus !

Si ...

Mr X a mis choix 1 zone Lille avec 1000 points et choix 2 Lyon avec 2000 points (c'est le plus élevé donc de toute façon on ne pourra pas mieux trouver sur Lyon).

Si aucun autre candidat avec un score de plus de 1000 points ne veut Lille en choix 1. Que fait-on ?

On lui affecté choix 1 ou choix 2 ?

Salut Denis,

Salut Girodo, Steelson,

joli casse-tête, en effet.

Le procédé décrit par Denis m'a l'air tout à fait correct et, en l'état actuel de ma réflexion, je ne vois pas d'autre façon de faire que de travailler directement sur la feuille en opérant des effacements de lignes successifs.

Je vais déjà partir dans cette direction ce qui m'éclairera, j'espère, un peu mieux pour une suite plus efficace!

Je ne vois pas, pour l'instant, comment utiliser des tableaux sans acrobaties interminables.

C'est peut-être un truc pour les 'Dico' ???

A+

De mon côté, je pense faire un système hybride basé sur quelques TCD pour éviter des calculs longs et répétitifs. Et non pas des effacements de lignes, mais l'ajout d'un colonne pour indiquer l'affectation d'une personne à son choix (en mettant NA pour les autres choix afin de les libérer) et la "comptabilité" quant aux zones affectées.

Je vais faire un premier passage (en plusieurs itérations) en retenant les choix 1 de tous jusqu'à concurrence non seulement des places disponibles mais aussi de la présence de la zone dans les autres choix des individus ayant des scores plus élevés. Je vais voir déjà cela combien d'individus je sauve de la panade !!

Après, je vais me poser pour redéfinir une stratégie pour la suite.

En tous cas merci Denis pour ce beau casse-tête !

Bon, pour le moment, j'ai réussi à caser 4858 individus sur leur choix 1 et 1122 sur leur choix 2, sur 13414 individus.

Cela m'a surtout permis de reprendre mon algorithme ...

Ouf !

7123 individus ont été affectés. Mais bon nombre sont restés sur le carreau ...

Exemple : #1 avec 413582 points et qui n'avait qu'un seul choix !! et pourquoi en choix 2 du reste ??

Les #15 et 19 un seul choix aussi avec des points plus que moyens !

Le #20 avait fait 3 choix, pfttt, tous les 3 lui sont passés sous le nez.

Bref, il faut maintenant être dirigiste et affecter d'office les zones restantes aux individus esseulés !

Bon, j'espère quand même que ma méthode est bonne. Je n'ai pas tout automatisé pour le moment ... ça mouline pas mal et je voulais conserver une certaine vision du fonctionnement.

Voilà, tout automatique ou presque après une préparation de 2 TCD.

Ne pas s'inquiéter des temps un peu long d'actualisation des TCD entre 2 itérations ...

Le cœur du sujet est le suivant :

capture d ecran 146

Lorsqu'un individu (#11748) exprime en choix 1 la zone #327, le TCD me permet de voir et calculer le nombre de fois où cette zone est aussi demandée avec des scores plus élevés (grand rectangle rouge) et donc de lui attribuer cette zone si et seulement si les disponibilités restantes permettraient de couvrir ces besoins (au cas où lesdits individus n'auraient pas trouvé une zone dans leur choix supérieur).

Après chaque itération, les autres choix des individus affectés sont neutralisés et le TCD est actualisé.

Si l'itération sur choix 1 ne donne plus rien, on effectue l'itération des choix 2 une fois et on revient en choix 1. Si l'itération en choix 2 ne donne plus rien, on passe en choix 3 une fois et on revient en choix 1; Et ainsi de suite. Jusque 6 !

De mon côté, la macro n'a mis "que" 8 mn. Je n'ai pas la meilleure config pour faire cela !

Sub affecter()
' données triées sur individu
' TCD onglet points trié décroissant sur points
' TCD nb_zones trié sur zone
Sheets("points").Select
MsgBox "Début !"

Dim c As Range, cptr%
Range("I2") = 0

debut:
choix = 1

suite:
Range("B2").Offset(0, choix) = "x"
cptr = 0

For i = 5 To Cells(Rows.Count, "B").End(xlUp).Row
    zone = Cells(i, "B").Offset(0, choix)
    If zone <> "" Then
        ligne = Application.Match(zone, Sheets("nb_zones").Columns("A"), 0)
        If (Sheets("nb_zones").Cells(ligne, "B") - Sheets("nb_zones").Cells(ligne, "J") > 0) Then
        '  nb de zones total                       nb zones déjà affectées
            ' les souhaits exprimés avec score plus grand bien que choix supérieur
            souhaits = IIf(i = 5 Or choix = 6, 0, Application.WorksheetFunction.CountIf(Range(Cells(5, "B").Offset(0, choix + 1), Cells((i - 1), "H")), Cells(i, "B").Offset(0, choix)))
            If Sheets("nb_zones").Cells(ligne, "B") - Sheets("nb_zones").Cells(ligne, "J") - souhaits > 0 Then
                Sheets("nb_zones").Cells(ligne, "J") = Sheets("nb_zones").Cells(ligne, "J") + 1
                cptr = cptr + 1
                Range("I2") = Range("I2") + 1
                qui = Cells(i, "B")
                For j = Application.Match(qui, Sheets("données").Columns("A"), 0) To Application.Match(qui, Sheets("données").Columns("A"), 1)
                    If Sheets("données").Cells(j, "AD") = zone Then
                        Sheets("données").Cells(j, "BK") = zone
                    Else
                        Sheets("données").Cells(j, "BK") = "NA"
                    End If
                Next
            End If
        End If
    End If
Next
If cptr <> 0 Then
    Range("B2").Offset(0, choix) = ""
    ActiveSheet.PivotTables(1).PivotCache.Refresh
    GoTo debut
Else
    If choix < 6 Then
        choix = choix + 1
        GoTo suite
    Else
        MsgBox "Terminé !"
        Exit Sub
    End If
End If
End Sub

https://www.cjoint.com/c/IJtd4PmSyBw

@Steelson :

- Par rapport à ton message de 17 h 22, M. X va être affecté sur son choix n°1 puisqu'il a le plus grand nombre de points à la fois sur son choix n°1 et sur son choix n°2. Désolé pour le temps de réaction, je n'avais pas vu ce message hier.

- Concernant ton message de 02 h17 :

- j'ai dû couper le tableau sinon il ne passait pas dans le forum parce que trop gros, donc certains individus n'ont pas l'intégralité de leur choix...

- Le but n'est pas d'affecter tous les individus coûte que coûte. S'ils ne sont pas affectés sur l'un de leurs choix, ils n'ont aucune envie d'être affectés sur une autre zone, ils préfèrent rester sur leur zone actuelle (non déclarée).

- Pour ton message de 5 h 57 :

- Vu que le fichier est coupé, les 8 minutes ne sont pas vraiment 8 minutes. Avant de lancer la macro, il faudrait donc rajouter 123 169 lignes pour estimer vraiment le temps de traitement.

En tout cas, merci infiniment pour le temps que tu m'as consacré jusqu'à maintenant, c'est vraiment une aide très précieuse !

Pour l'instant, la logique de la macro semble correcte. Je vais la tester grandeur nature dès que possible et je vous tiens au courant.

Bon weekend !

OK merci pour ce retour.

Il faudra t'armer d'un ordinateur très puissant ! car les TCD seront lourds à mettre en place (*)

Je pense qu'il y a une toute petite erreur de logique de ma part qui pourrait inverser quelques cas; il faut que je peaufine la réflexion ... il s'agit des souhaits auxquels il faut ajouter les souhaits dont les choix sont plus "importants" et qui n'ont pas été couverts.

(*) une fois au point (le TCD permet surtout de supporter la réflexion car c'est très visuel), je vais passer à une macro "pure" qi ne s'appuiera pas sur un TCD. Il est alors probable que cela facilitera la mise en oeuvre à grande échelle.

Vu la taille de tes données, et comme l'a dit aussi curulis57, je pense qu'il faut passer directement par une macro pure ET sortir tout de suite les individus affectés dans une autre onglet.

Bonjour,

Je pense que l'algorithme écrit précédemment négligeait des cas rares mais tout à fait possible, donc dès qu'une affectation est actée, les autres choix étant libérés, l'analyse reprend au tout début (pour un cas où ce choix n'aurait pas pu être confirmé avec un score un peu inférieur) !

Je suis reparti d'un jeu test complet avec tous les choix :

  • 1000 individus
  • 6 choix
  • 200 zones
  • environ 950 places

Temps de traitement ... quelques minutes, mais attention cela risque d'être exponentiel (voire durée plus d'une nuit dans ton cas). L'avancement peut être contrôlé dans la barre d'état en bas à gauche (StatusBar).

Par ailleurs, pour accélérer,

  • les données inutiles sont effacées ... ATTENTION DE BIEN GARDER UNE COPIE des données avant lancement.
  • j'ai séparé une base de données zones et nombre de places par zones
  • je n'ai repris en tableau que les données pertinentes : individu (matricule), choix et points.

Quelques résultats :

  • reste 15 places non pourvues
  • reste 54 personnes non affectées
  • certaines affectations ont été faites sur des choix 6

J'ai aussi un jeu de données plus faible qui va me permettre d'analyser les choix rejetés pour savoir quel % de cas cités ci-dessus a été rencontré (cela donnera une idée) et quels cas.

Sub affecter()
Dim z As Worksheet, i As Long, j As Long
Set z = Sheets("Zones")
Sheets("data").Select
ActiveSheet.ListObjects(1).Sort.Apply

Dim EtatStatusBar As Boolean
EtatStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False

choix = 1
compteur = 0

i = 1
debut:
Do Until Cells(i, "A") = ""
    i = i + 1
reprise:
    If Cells(i, "D") = choix Then
        ligne = Application.Match(Cells(i, "C"), z.Columns("A"), 0)
        If z.Cells(ligne, "B") - z.Cells(ligne, "C") <= 0 Then
            Rows(i).Delete Shift:=xlUp ' pas de disponibilité
            GoTo reprise ' sans incrémentation car ligne supprimée
        Else
            besoins = IIf(i = 2, 0, Application.WorksheetFunction.CountIf(Range("C2:C" & (i - 1)), Cells(i, "C")))
            If z.Cells(ligne, "B") - z.Cells(ligne, "C") - besoins > 0 Then
                z.Cells(ligne, "C") = z.Cells(ligne, "C") + 1
                compteur = compteur + 1
                Application.StatusBar = " " & compteur & " affectés"
                qui = Cells(i, "A")
                transfert i, "data", "Affectations"
                For j = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
                    If Cells(j, "A") = qui Then Rows(j).Delete Shift:=xlUp ' autres choix supprimés car inutiles
                Next
                choix = 1
                i = 2
                GoTo reprise ' au tout début (choix 1 et première ligne)
            End If
        End If
    End If
Loop
If choix < 6 Then
    choix = choix + 1
    i = 1
    GoTo debut
End If

fin:
Application.ScreenUpdating = True
Application.StatusBar = False
Application.DisplayStatusBar = EtatStatusBar
MsgBox "Terminé !"

Sheets("Synthèse").Select
ActiveSheet.PivotTables(1).PivotCache.Refresh

End Sub

Sub transfert(ligne As Long, depuis As String, vers As String)
Dim t1 As ListObject
Dim t2 As ListObject
    Set t1 = Sheets(depuis).ListObjects(1)
    Set t2 = Sheets(vers).ListObjects(1)
    t2.ListRows.Add
    t1.ListRows(ligne - t1.HeaderRowRange.Row).Range.Copy Destination:=t2.DataBodyRange(t2.ListRows.Count, 1)
    t1.ListRows(ligne - t1.HeaderRowRange.Row).Range.Delete
End Sub
Rechercher des sujets similaires à "trier tableau vba"