tirage d'équipe aléatoire

[Lautrec]

Bjr
voici ce que je cherche à faire:

je rentre une liste d'élèves dans excel (jusque là, ça va !)

je selectionne qq élèves (un 'x' dans une cellule juste devant leur nom par exemple)

de là, ces éléves 'marqués' sont inscrits ailleurs(dans une autre feuille que j'imprimerais par exemple) comme chef d'équipe (donc autant d'équipes que d'élèves 'marqués')

les autres élèves de la liste sont ensuite répartis aléatoirement dans lesdites équipes.

ça parait pas trop compliqué dit comme ça.....mais ça fait déjà qq temps que je bute dessus...!!!

Si qqn voit comment faire....merci d'avance

 

[myDearFriend!]

Bonjour Lautrec,

Ci-joint un exemple pouvant peut-être répondre à ta demande...

Sub Traitement()
Dim Plage As Range
Dim TabTemp As Variant
Dim L As Long, N As Long
Dim C As Byte, nbCol As Byte
      Application.ScreenUpdating = True
      'Charge les données dans un tableau variant temporaire
      With Sheets('Liste Elèves')
            L = .Range('B65536').End(xlUp).Row
            TabTemp = .Range(.Cells(2, 1), .Cells(L, 3)).Value
      End With
      With Sheets('Equipes')
            'Copie de la liste et tri aléatoire des élèves
            .Cells.ClearContents
            Set Plage = .Range(.Cells(1, 1), .Cells(UBound(TabTemp, 1), 3))
            Plage.Value = TabTemp
            Randomize
            For L = 1 To UBound(TabTemp, 1)
                  If .Cells(L, 1) <> '' Then
                        nbCol = nbCol + 1
                  Else
                        .Cells(L, 3) = Int((UBound(TabTemp, 1)) * Rnd + 1)
                  End If
            Next L
            Plage.Sort Key1:=Plage.Range('A1'), Order1:=xlAscending, _
                        Key2:=Plage.Range('C1'), Order2:=xlAscending, Header:=xlGuess
            'Remise en forme de la liste triée par équipe
            TabTemp = Plage.Columns(2).Value
            .Cells.ClearContents
            L = 1
            C = 0
            For N = 1 To UBound(TabTemp, 1)
                  C = C + 1
                  If C > nbCol Then
                        C = 1
                        L = L + 1
                  End If
                 .Cells(L, C) = TabTemp(N, 1)
            Next N
            Application.ScreenUpdating = True
            .Activate
      End With
End Sub

Cordialement, [file name=PourLautrec.zip size=15841]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/PourLautrec.zip[/file]

 

[lautrec]

:woohoo:

alors là, bravo !

le top!

c'est trop bien!!!

Merci à toi mDf !!!


(et tout ça en rien de temps......)
Merci bcp!

 

[Gérard DEZAMIS]

Bonsoir à tous

Je passe, je goûte, j'apprécie, je me précipite dessus !

Bien joué Didier c'est super pratique.
En plus pour les élèves : 'C'est la machine qui fait' donc pas de trucage et de favoritisme !

un grand Bravo et merci encore

à+ GD