XL 2010 créer équipes sportives mixtes selon 3 critères (sexe/points marqués/type de compet)

[chvalet]

Bonjour

j'ai une 1ere feuille excel nommée "info" avec sur chaque ligne les performances individuelles d'un sportif à 6 épreuves ainsi qu'un total individuel

Chaque sportif appartient à un club

Chaque club peut avoir 1 à N équipes classées dans un des 4 championnats possibles (Lyc Exc/Lyc Etab/Clg Exc/Clg Etab)

Pour être conforme (et classée) chaque équipe doit être constituée de 3 sportifs et doit être obligatoirement mixte (soit 2 F/1 G ou 2G/1F).

dans la 2e feuille "rang"
je souhaiterais que les 4 classements correspondant aux 4 types de compétition puissent apparaître les uns après les autres selon 2 choix :
si équipe préformée (cellule t2) = oui , on utilise les infos de la colonne L pour créer les classements
si équipe libre (cellule t2) = non , les classements se créent par rapport aux perfs des 3 meilleures athlètes possibles pour que l'équipe soit mixte

Un colistier aurait il une idée ?


merci d avance

chvalet

 

[ODVJ]

Bonjour,

Je me disais que j'avais déjà vu cette question recemment....
Ici sans doute : https://www.excel-downloads.com/threads/créer-des-equipes-mixtes.20012837/#post-20096607

Cordialement

 

[chvalet]

Bonjour

merci ODVJ

je suis incapable de retranscrire et de modifier ce qui est dans cette macro du post
https://www.excel-downloads.com/threads/créer-des-equipes-mixtes.20012837/#post-20096607

il y a des similitudes (mixité) mais le changement (3 athlètes contre 5 dans l'autre post)

Sub CreEquipeMixteV4()
Dim Plage, dico, Clé, T1, T2, TT, i As Long, TResult, Tablo, PosF, PosG
Dim NbTh As Integer, NbP As Integer, nbequipe As Integer, j As Integer, ii As Integer, jj As Integer
Dim Complet As Boolean, CompletF As Boolean, CompletG As Boolean, FlagF As Boolean, FlagG As Boolean
Dim x As Integer, DerL As Integer
PosF = Array(3, 4, 7)
PosG = Array(5, 6, 7)
Set dico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
'**** vidage résultats
With Worksheets("RESULTATS")
    DerL = .Range("B" & Rows.Count).End(xlUp).Row
    If DerL > 1 Then .Range("A2:A" & DerL).EntireRow.Delete
 
End With
'**
With Worksheets("BASE")
Set Plage = .Range("A2:M" & .Range("A" & Rows.Count).End(xlUp).Row)
Plage.Columns(13).ClearContents
End With
'* suppression des lignes <> LycG et LycF
Plage.AutoFilter Field:=5, Criteria1:="<>LycF", Operator:=xlAnd, Criteria2:="<>LycG"
If Application.Subtotal(103, Plage.Columns(1)) > 0 Then
    Plage.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
Plage.AutoFilter Field:=5
'* suppression des lignes Présent=0
Plage.AutoFilter Field:=12, Criteria1:="=0"
If Application.Subtotal(103, Plage.Columns(1)) > 0 Then
    Plage.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
Plage.AutoFilter Field:=12

'** Tri dans l'ordre des clubs et points croissants
Plage.Sort Key1:=Range("H1"), Order1:=xlAscending, Key2:=Range("F2"), Order2:=xlAscending, Header:=xlGuess

TT = Plage
ReDim T1(1 To 2)
T2 = T1

For i = LBound(TT, 1) To UBound(TT, 1)
    If Not dico.exists(CStr(TT(i, 8))) Then dico(CStr(TT(i, 8))) = T2
    T1 = dico(CStr(TT(i, 8)))
    If Right(TT(i, 4), 1) = "F" Then
        T1(1) = T1(1) + 1
    Else
        T1(2) = T1(2) + 1
    End If
    dico(CStr(TT(i, 8))) = T1
Next

x = 0 ' Nb d' équipes
ReDim TResult(1 To 8, 1 To 1)

For Each Clé In dico.keys
    NbTh = Int((dico(Clé)(1) + dico(Clé)(2)) / 5) '
   NbP = Int(WorksheetFunction.Min(dico(Clé)(1), dico(Clé)(2)) / 2)
    nbequipe = WorksheetFunction.Min(NbTh, NbP)
    Complet = False: CompletF = False: CompletG = False: FlagG = False: FlagF = False
    If nbequipe > 0 Then
        Erase TResult

        Plage.AutoFilter Field:=8, Criteria1:=Clé
        Tablo = Plage.SpecialCells(xlCellTypeVisible)
        ReDim TResult(1 To 8, 1 To nbequipe)
        For i = 1 To nbequipe
            TResult(1, i) = Clé
            TResult(2, i) = i
        Next
        For j = LBound(Tablo) To UBound(Tablo)
            FlagG = False: FlagF = False
            If Complet Then Exit For
            If Right(Tablo(j, 4), 1) = "F" Then
                For ii = 1 To nbequipe
                    For jj = LBound(PosF) To UBound(PosF)
                        If TResult(PosF(jj), ii) = "" Then
                            TResult(PosF(jj), ii) = Tablo(j, 1) & "-" & Tablo(j, 2) & "-" & Tablo(j, 3) & "-" & Tablo(j, 4)
                            TResult(8, ii) = TResult(8, ii) + Tablo(j, 6)
                            Tablo(j, 13) = ii
                            FlagF = True
                            Exit For
                        End If
                    Next
                    If FlagF Then Exit For
                Next
                If Not FlagF Then CompletF = True
            Else
                For ii = 1 To nbequipe
                    For jj = LBound(PosG) To UBound(PosG)
                        If TResult(PosG(jj), ii) = "" Then
                            TResult(PosG(jj), ii) = Tablo(j, 1) & "-" & Tablo(j, 2) & "-" & Tablo(j, 3) & "-" & Tablo(j, 4)
                            TResult(8, ii) = TResult(8, ii) + Tablo(j, 6)
                            Tablo(j, 13) = ii
                            FlagG = True
                            Exit For
                        End If
                    Next
                    If FlagG Then Exit For
                Next
                If Not FlagG Then CompletG = True
           End If
            If CompletF And CompletG Then Complet = True
        Next j
        x = x + nbequipe
        With Worksheets("BASE").Range("A" & Plage.SpecialCells(xlCellTypeVisible).Row)
        .Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo
        End With
        With Worksheets("RESULTATS")
        .Range("B" & .Range("B" & Rows.Count).End(xlUp).Row + 1).Resize(UBound(TResult, 2), UBound(TResult, 1)) = Application.Transpose(TResult)
        End With
    End If
Next Clé

With Worksheets("RESULTATS")
.Range("A2:A" & x + 1).Formula = "=RANK(I2,$I$2:$I$" & x + 1 & ",1)"
.Range("A2:I" & x + 1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
.Range("A2:I" & x + 1).Borders.Weight = xlThin
End With
Plage.AutoFilter Field:=8
Application.ScreenUpdating = True
End Sub

 

[chvalet]

Re,bonjour

j'ai modifier mon fichier, il ressemble plus à celui ci
https://www.excel-downloads.com/threads/créer-des-equipes-mixtes.20012837/#post-20096607

mais maintenant c'est dans la macro , je n'arrive pas à modifier pour masser de 5 athlete( 2 g/2f + ?) à 3 athlètes (1g/1f+ ?)

Un forumeur aurait-il une idée ?
Peut être le créateur de l'ancien ? M Paf ?

merci
Chvalet

 

[chvalet]

Hello les Forumeurs

Aucune idée ??

merci
Chvalet

 

[chvalet]

Bonjour

je souhaiterais faire évoluer le fichier classement mixte en ajoutant des classements par équipe de 5 par sexe : féminin et masculin.
J'ai crée un post ici https://www.excel-downloads.com/threads/creer-des-classements-par-sexe.20020820/

Dans l'attente de vous lire
Je vous remercie d'avance
Chvalet