tirage d'équipe aléatoire

L

Lautrec

Guest
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!

XLDnaute Barbatruc
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]
 

Pièces jointes

  • PourLautrec.zip
    15.5 KB · Affichages: 138

Membres actuellement en ligne

Statistiques des forums

Discussions
312 816
Messages
2 092 361
Membres
105 378
dernier inscrit
y07