XL 2013 Incrémentation de numéros d'anonymat pour des candidats à un examen plus barre de progression

Djibysadji · 21 Juin 2022

Bonsoir à tous!
Je cherche comment incrémenter des numéros d'anonymat pour des candidats à un examen en partant d'un numéro appelé début de série. Ce numéro peut être saisie dans une cellule ou texbox avec un bouton "incrémenter" qui déclenchera cette incrémentation. Nous aimerions aussi avoir une barre qui montrera la progression.
En même temps que l'incrémentation se fera, un numéro d'anonymat sera affecté à chaque candidat dans la colonne appelée ANO de la feuille "CANDIDATS"

djibysadji

AtTheOne · 8 Juillet 2022

Bonjour à toutes & à tous, bonjour @Djibysadji
Voilà ce que je te propose :
Une liste de candidats (Nom, Prénom, Date de Naissance "tout cela en aléatoire dans l'exemple") avec 25000 lignes

Une macro qui

Tri dans l'ordre Alphabétique la liste (+Date de naissance)
Demande le début de série
Remplit un tableau avec une liste séquentielle
Affecte les N° créés de manière aléatoire aux candidats

Le code se trouve dans le module Mdl_AtTheOne :

Enrichi (BBcode):

Sub Tirage()
    Dim NbL As Long, Réponse, Début As Long, i As Long, j As Long, k As Long
    
    'Nombre de ligne du tableau "tb_ListeAlpha"
    NbL = Sh_Candidats.[tb_ListeAlpha].Rows.Count
    'Effacement des N° ANO précédents
    Sh_Candidats.[tb_ListeAlpha[ANO]].ClearContents
    
    'Tri dans l'ordre alphabétique + Date de naissance
    With Sh_Candidats.ListObjects("tb_ListeAlpha").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Nom]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Prénom]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Date de Naissance]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

    'Demande du N° de Début de série
    Réponse = Application.InputBox(Title:="Affectation des N° d'anonymat : Début de série", Prompt:="saisir un nombre entier :", Type:=1)
    If Réponse = False Then Exit Sub
    Début = CLng(Réponse)
    ReDim Temp(1 To NbL)
    ReDim TbRés(1 To NbL, 1 To 1)
    
    With UsF_Barre
        'Affichage de la barre d'avancement (non modal)
       .Show vbModeless
        'Remplir le tableau Temp avec la suite des N°
        For i = 0 To NbL - 1
            Temp(i + 1) = Début + i
        Next i
        'Remplir TbRés dans un ordre aléatoire
        For i = NbL To 1 Step -1
            k = Int((i) * Rnd + 1)
            TbRés(i, 1) = Temp(k)
            For j = k To i - 1
                Temp(j) = Temp(j + 1)
            Next j
            ReDim Preserve Temp(1 To i)
            'Mise à jour de la barre d'avancement
            Avancement = Int((NbL - i + 1) / NbL * UsF_Barre.Lbl_Fond.Width)
            .Lbl_Avancement.Width = Avancement
            .Caption = "Avancement " & Int(Avancement / 500 * 100) & "% - " & i
            DoEvents
        Next i
        'Coller les N° dans le tableau "tb_ListeAlpha"
        Sh_Candidats.[tb_ListeAlpha].Columns(1) = TbRés
        .Hide
    End With
    Unload UsF_Barre
    
End Sub

Amicalement
Alain

sylvanu · 8 Juillet 2022

Bonjour Djibysadji, AtTheOne,
Un essai en PJ, en un peu plus rapide.
L'astuce est de mettre en Numéro des nombres aléatoires, puis de trier sur cette colonne.
On supprime ces nombres, on les remplace par les N° dans l'ordre, et on retrie sur Nom Prénom.
A la fin on a une distribution aléatoire des attributions de nom.
J'ai supprimé la barre de progression car sur mon vieux PC ça met 0.3s.

VB:

Sub TirageAuSort()
    Réponse = Application.InputBox(Title:="Affectation des N° d'anonymat : Début de série", Prompt:="Saisir un nombre entier :", Type:=1)
    If Réponse = False Then Exit Sub                                            'Demande du N° de Début de série ( Idem AtTheOne )
    Début = CLng(Réponse)
    T0 = Timer
    Application.ScreenUpdating = False
    Range("tb_ListeAlpha[Numéro]").ClearContents                                ' Efface colonne Numéro
    [A2].FormulaLocal = "=alea()"                                               ' Met des nombres aléatoires dans cette colonne
    With ActiveSheet.ListObjects("tb_ListeAlpha").Sort
        .SortFields.Clear                                                       ' Tri croissant sur cette colonne
        .SortFields.Add Key:=Range("tb_ListeAlpha[Numéro]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
        Range("tb_ListeAlpha[Numéro]").ClearContents                            ' Efface colonne Numéro
        [A2].FormulaLocal = "=LIGNE()-2+" & Début                               ' Affecte les N°
        Range("tb_ListeAlpha[Numéro]") = Range("tb_ListeAlpha[Numéro]").Value   ' Supprime les formules, y met les valeurs
        .SortFields.Clear                                                       ' Nouveau tri Nom Prénom Date naissance
        .SortFields.Add Key:=Range("tb_ListeAlpha[Nom]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("tb_ListeAlpha[Prénom]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("tb_ListeAlpha[Date de Naissance]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
    [H9] = Format(1000 * (Timer - T0), "0 ms")                                  ' Met le temps mesuré en H9 ( à supprimer )
End Sub

AtTheOne · 8 Juillet 2022

Re-Bonjour

sylvanu à dit:
Un essai en PJ, en un peu plus rapide.

Bon, évidemment si tu fais la course 🏃‍♂️... J'ai perdu d'avance 🐌...
Mais j'aimais bien regarder ma barre d'avancement 😉

Amicalement
Alain

AtTheOne · 9 Juillet 2022

Bonjour @Djibysadji
Pourrais tu dire si les solutions proposées te conviennent et éventuellement en marquer une comme solution ...
Merci d'avance
Amicalement
Alain

Djibysadji · 22 Juillet 2022

AtTheOne à dit:

Bonjour à toutes & à tous, bonjour @Djibysadji
Voilà ce que je te propose :
Une liste de candidats (Nom, Prénom, Date de Naissance "tout cela en aléatoire dans l'exemple") avec 25000 lignes

Une macro qui

Tri dans l'ordre Alphabétique la liste (+Date de naissance)
Demande le début de série
Remplit un tableau avec une liste séquentielle
Affecte les N° créés de manière aléatoire aux candidats

Le code se trouve dans le module Mdl_AtTheOne :

Enrichi (BBcode):

Sub Tirage()
    Dim NbL As Long, Réponse, Début As Long, i As Long, j As Long, k As Long
   
    'Nombre de ligne du tableau "tb_ListeAlpha"
    NbL = Sh_Candidats.[tb_ListeAlpha].Rows.Count
    'Effacement des N° ANO précédents
    Sh_Candidats.[tb_ListeAlpha[ANO]].ClearContents
   
    'Tri dans l'ordre alphabétique + Date de naissance
    With Sh_Candidats.ListObjects("tb_ListeAlpha").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Nom]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Prénom]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Sh_Candidats.[tb_ListeAlpha[Date de Naissance]], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

    'Demande du N° de Début de série
    Réponse = Application.InputBox(Title:="Affectation des N° d'anonymat : Début de série", Prompt:="saisir un nombre entier :", Type:=1)
    If Réponse = False Then Exit Sub
    Début = CLng(Réponse)
    ReDim Temp(1 To NbL)
    ReDim TbRés(1 To NbL, 1 To 1)
   
    With UsF_Barre
        'Affichage de la barre d'avancement (non modal)
       .Show vbModeless
        'Remplir le tableau Temp avec la suite des N°
        For i = 0 To NbL - 1
            Temp(i + 1) = Début + i
        Next i
        'Remplir TbRés dans un ordre aléatoire
        For i = NbL To 1 Step -1
            k = Int((i) * Rnd + 1)
            TbRés(i, 1) = Temp(k)
            For j = k To i - 1
                Temp(j) = Temp(j + 1)
            Next j
            ReDim Preserve Temp(1 To i)
            'Mise à jour de la barre d'avancement
            Avancement = Int((NbL - i + 1) / NbL * UsF_Barre.Lbl_Fond.Width)
            .Lbl_Avancement.Width = Avancement
            .Caption = "Avancement " & Int(Avancement / 500 * 100) & "% - " & i
            DoEvents
        Next i
        'Coller les N° dans le tableau "tb_ListeAlpha"
        Sh_Candidats.[tb_ListeAlpha].Columns(1) = TbRés
        .Hide
    End With
    Unload UsF_Barre
   
End Sub

Amicalement
Alain

sylvanu à dit:

Bonjour Djibysadji, AtTheOne,
Un essai en PJ, en un peu plus rapide.
L'astuce est de mettre en Numéro des nombres aléatoires, puis de trier sur cette colonne.
On supprime ces nombres, on les remplace par les N° dans l'ordre, et on retrie sur Nom Prénom.
A la fin on a une distribution aléatoire des attributions de nom.
J'ai supprimé la barre de progression car sur mon vieux PC ça met 0.3s.

VB:

Sub TirageAuSort()
    Réponse = Application.InputBox(Title:="Affectation des N° d'anonymat : Début de série", Prompt:="Saisir un nombre entier :", Type:=1)
    If Réponse = False Then Exit Sub                                            'Demande du N° de Début de série ( Idem AtTheOne )
    Début = CLng(Réponse)
    T0 = Timer
    Application.ScreenUpdating = False
    Range("tb_ListeAlpha[Numéro]").ClearContents                                ' Efface colonne Numéro
    [A2].FormulaLocal = "=alea()"                                               ' Met des nombres aléatoires dans cette colonne
    With ActiveSheet.ListObjects("tb_ListeAlpha").Sort
        .SortFields.Clear                                                       ' Tri croissant sur cette colonne
        .SortFields.Add Key:=Range("tb_ListeAlpha[Numéro]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
        Range("tb_ListeAlpha[Numéro]").ClearContents                            ' Efface colonne Numéro
        [A2].FormulaLocal = "=LIGNE()-2+" & Début                               ' Affecte les N°
        Range("tb_ListeAlpha[Numéro]") = Range("tb_ListeAlpha[Numéro]").Value   ' Supprime les formules, y met les valeurs
        .SortFields.Clear                                                       ' Nouveau tri Nom Prénom Date naissance
        .SortFields.Add Key:=Range("tb_ListeAlpha[Nom]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("tb_ListeAlpha[Prénom]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("tb_ListeAlpha[Date de Naissance]"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .Apply
    End With
    [H9] = Format(1000 * (Timer - T0), "0 ms")                                  ' Met le temps mesuré en H9 ( à supprimer )
End Sub

Bonsoir!
Je vous présente mes excuses pour avoir mis beaucoup de temps avant de répondre. Pour des raisons indépendantes de ma volonté je suis restés quelques temps sans visiter le site.

Pour revenir au sujet, ce code marche parfaitement. Un joli travail! Cependant j'aimerais bien que les numéros incrémentés soient consécutifs(n+1). n étant le début de la série à générer et le numéro du premier candidats dans l'ordre alphabétique.

Cordialement

Djibysadji · 22 Juillet 2022

AtTheOne à dit:
Bonjour @Djibysadji
Pourrais tu dire si les solutions proposées te conviennent et éventuellement en marquer une comme solution ...
Merci d'avance
Amicalement
Alain

Bonsoir!
Je vous présentes mes excuses pour avoir mis beaucoup de temps avant de réagir par rapport à vos propositions. Pour des raisons indépendantes de ma volonté je suis resté assez longtemps sans visiter le site.

Pour revenir au sujet, J'ai testé les deux propositions:
La première proposition marche parfaitement. Du joli travail! Cependant j'aimerais bien que les numéros soient incrémentés à n+1. n étant le début de la série et le numéro du premier candidats dans l'ordre alphabétique.
Pour la deuxième solution j'ai rencontré une erreur. Au click sur le bouton, la boite de dialogue affiche "Objet requis"

Cordialement

sylvanu · 22 Juillet 2022

Djibysadji à dit:
Cependant j'aimerais bien que les numéros incrémentés soient consécutifs(n+1). n étant le début de la série à générer et le numéro du premier candidats dans l'ordre alphabétique.

Vous pourriez expliquer ?
Si vous appuyez sur le bouton, on vous demande à quel numéro on doit commencer, puis ensuite on fait n+1.

Djibysadji à dit:
en partant d'un numéro appelé début de série. Ce numéro peut être saisie dans une cellule ou texbox avec un bouton

C'est exactement ce que vous demandez au post #1.

AtTheOne · 23 Juillet 2022

Bonjour à toutes & à tous, bonjour @Djibysadji,
Pour les deux solutions, les n° attribués sont consécutifs mais répartis aléatoirement, sinon ce n'est plus vraiment des n° d'anonymat, car il suffit d'avoir la liste des candidats et le n° de départ pour retrouver le n° de n'importe quel candidat ...
Et pour faire cela plus besoin de macro,
Trier la liste dans l'ordre alphabétique,
Ecrire à côté du premier nom le premier n°, juste dessous incrémenter de 1
EDIT : "sélectionner ces deux cellules" et double cliquer sur le petit carré en bas à droite de la cellule, la liste de n° successifs se remplit toute seule...
Bon courage
Amicalement
Alain

XL 2013 Incrémentation de numéros d'anonymat pour des candidats à un examen plus barre de progression

Djibysadji

XLDnaute Nouveau

AtTheOne

XLDnaute Accro

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

AtTheOne

XLDnaute Accro

AtTheOne

XLDnaute Accro

Djibysadji

XLDnaute Nouveau

Djibysadji

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

AtTheOne

XLDnaute Accro

Discussions similaires

XL 2013 Incrémentation de numéros d'anonymat pour des candidats à un examen plus barre de progression

XLDnaute Nouveau

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Accro

XLDnaute Accro

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency