XL 2010 créer des equipes mixtes

deps · 19 Novembre 2016

Bonjour

j'ai un fichier avec une feuille "base" comportant des résultats individuel de course

colonne A : n° du dossard
colonne B : nom
colonne c : prenom
colonne D : catégorie
Colonne E : type
colonne F : les points marqués par le coureur (plus c'est petit mieux c'est!)
colonne G: Numero course
colonne H :numéro de code du club
colonne I le nom du club
colonne J : ville club
colonne K : Annee coureur
colonne L: présents/absent
colonne M : n° de l'équipe

je souhaiterais réaliser des classements par équipe en totalisant les points des 5 meilleurs concurrents du meme club

1- Comment automatiser la suppression des lignes dont le type (colonne E) est <> LycG ou LycF

2- Comment automatiser la suppression des lignes des absents (colonne L : Lx = 0 )

3-Comment créer toutes les équipes (de 5 concurrents) mixte obligatoirement avec cette règle
2 Filles +2 garçons , le 5e de l'équipe étant le meilleur coureur restant (Fille ou Garçon selon les points)

colonne M : affecter un numéro d'équipe (1 à n) pour chaque coureur ayant été positionné dans une équipe valable (règle de la mixité ce dessus)

4- en feuille "Resultats"
comment automatiser le classement ?

=> en PJ le fichier exemple

Un forumeur aurait il des solutions ,?

merci
Deps

Paf · 20 Novembre 2016

Bonjour,

un essai macro à tester :

VB:

Sub CreEquipeMixte()
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
PosF = Array(3, 4, 7)
PosG = Array(5, 6, 7)
Set dico = CreateObject("Scripting.Dictionary")
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 décroissants
Plage.Sort Key1:=Range("H1"), Order1:=xlAscending, Key2:=Range("F2"), Order2:=xlDescending, 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 ' N° des é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) = x + 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)
                            TResult(8, ii) = TResult(8, ii) + Tablo(j, 6)
                            Tablo(j, 13) = x + 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)
                            TResult(8, ii) = TResult(8, ii) + Tablo(j, 6)
                            Tablo(j, 13) = x + 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 & ",0)"
.Range("A2:I" & x + 1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
End With
Plage.AutoFilter Field:=8
End Sub

A+

deps · 20 Novembre 2016

Bonsoir PAf

merci de t'être penché sur ce probleme.

1/ j'ai remarqué que ton classement est inversé.
le meilleur étant celui qui a le plus petit total de points
le tien est celui qui a le plus grand.

2/ n° equipe - colonne C
ta numérotation va de 1 à x mais sur toute les équipes
serait il possible d'avoir une numérotation par n° de club ?
c'est à dire que la meilleure équipe de chaque club = equipe 1 ; la suivante 2 etc...

voici le classement que je trouve manuellement
place numclub n° equipe dossard 1 dossard 2 dossard 3 dossard 4 dossard 5 points
1 11169 1 9032 18 10049 10048 9913 11,061
2 11169 2 9030 9034 10019 10043 9917 25,73
3 11169 3 21 9035 10022 9914 10046 38,074
4 11169 4 19 9020 10047 9916 10021 52,982
5 11169 5 20 9027 9915 10018 10044 66,369
6 11169 6 22 9015 17 34 10020 82,976
7 11184 1 9039 25 31 43 10066 99,404
8 11165 1 11 10 10011 10012 9910 102,594
9 11169 7 9018 23 10045 9918 9911 104,681
10 11121 1 9007 9008 10075 993 10061 129,845
11 11169 8 9031 13 15 35 9912 133,631
12 11184 2 26 9040 29 40 42 142,606
13 11121 2 9004 9009 10033 992 10031 201,193

encore merci
deps

Paf · 21 Novembre 2016

Re,

Un peu plus que penché même....

la nouvelle version incluant les modifs pour les points 1 et 2

VB:

Sub CreEquipeMixteV2()
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
PosF = Array(3, 4, 7)
PosG = Array(5, 6, 7)
Set dico = CreateObject("Scripting.Dictionary")
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 ' N° des é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)
  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)
  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
End With
Plage.AutoFilter Field:=8
End Sub

Un souci pour lequel je ne trouve pas de solution:

si pour un club on a 4 F et 6 G, on aura 2 équipes.
Si les F ont les 4 meilleurs résultats :
la première => dossard1 (F) équipe 1
la deuxième => dossard2 (F) équipe 1
la troisième => dossard5 (Mixte) équipe 1
La quatrième => dossard1 (F) équipe 2
et il manquera dossard2 (F) équipe2

Pour l'inverse (4 G et 6F) c'est vrai également, mais comme il y a beaucoup plus de G le problème ne devrait pas se présenter.

A+

Edit: après quelques soucis pour insérer le code (pas de fenêtre de saisie) , l'indentation n'est pas respectée !

deps · 21 Novembre 2016

Bonjour

merci, évidemment je me doute que "très très bien penché" est plus juste vu la longueur du code.

pour les résultats
il faut absolument 2 membres du même sexe par équipe plus le meilleur restant (plus petit points)
ne sachant pas programmer je ne peux pas t aider
J'avais pensé à un tri pat "numclub" "type" et "points"
faire le rang
prendre les 2 premiers f et deux premier G (soit 4 concurrents) et leur donner un n° d'équipe (1)
puis re-trier en filtrant ceux qui ne sont pas numerotés et prendre le meilleur (= 5e de l'équipe)
puis recommencer pour l'équipe du club suivante
ça nécessite peut etre un copier coller sur une feuille à part ?

bon je teste ton code...

cordialement
Deps

Paf · 21 Novembre 2016

re,

deps à dit:
J'avais pensé à un tri pat "numclub" "type" et "points"
faire le rang
prendre les 2 premiers f et deux premier G (soit 4 concurrents) et leur donner un n° d'équipe (1)
puis re-trier en filtrant ceux qui ne sont pas numerotés et prendre le meilleur (= 5e de l'équipe)
puis recommencer pour l'équipe du club suivante

le problème évoqué au post 4 n'est pas écarté pour autant:

après l'affectation de 2 F et 2 G prendre le meilleurs des restants, si le meilleurs est F alors on l'inclut dans l'équipe, et il ne reste plus qu'une F pour la deuxième équipe.

Il faudrait constituer toutes les équipes F d'emblée, puis toutes les équipes G, puis compléter en 'piochant' dans la liste des restants. Mais les équipes ne seraient pas optimisées au niveau points.

A+

deps · 21 Novembre 2016

Bonjour

on calcule toujours pour avoir l'équipe 1 meilleure, quitte à ne pas avoir d'équipe 2 .
Les équipes se constituent selon le meilleur classement individuel des 2 F et des 2 g puis du meilleur restant
==>les autres équipes sont non conformes

j'ai vérifié tes résultats, dans la version macro2, ça fonctionne
identiques à mes résultats manuels mais forcément plus rapide merci

dans la base, il y a une erreur de ma part pour le dossard 10039, il faut lui affecter 21,795 points

Cordialement

Deps

deps · 21 Novembre 2016

Re-Bonjour

serait-ce possible d'ajouter dans la macro un vidage de la feuille "resultats" avant nouveau classement ?

merci
Deps

deps · 21 Novembre 2016

Bonjour PAf, Forum

Dans la feuille résultats
A la place du n° de dossard, serait ce possible de concaténer "n° dossard-nom-prénom-catégorie" ?

encore merci
Deps

Paf · 21 Novembre 2016

re,

avec 'vidage' et concaténation:

VB:

Sub CreEquipeMixteV3()
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:I" & DerL).ClearContents
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 ' N° des é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
End With
Plage.AutoFilter Field:=8
Application.ScreenUpdating = True
End Sub

A+

deps · 21 Novembre 2016

Bonjour

Excellent merci !!!!
A force de t'y pencher , tu risques de tomber

est ce possible d'avoir un quadrillage automatique des résultats par équipe ?

Merci
Deps

Paf · 21 Novembre 2016

re,

avec le quadrillage:

VB:

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

A+

deps · 21 Novembre 2016

Bonsoir Paf

merci.
je teste de suite .

Deps

deps · 21 Novembre 2016

Bonsoir PAf, Forum

super nickel !!!

Enfin, les données de la feuille Base sont récupérées d'un fichier export.xls joint

1- Dans le fichier rang-equipev4.xls
Serait ce possible que le bouton macro de la feuille "menu" importe les données du fichier export.xls vers la feuille "import" ?
la feuille "import" permettrait de toujours avoir les données "propres" après plusieurs utilisations de "Base".

2- Est-ce possible de créer une macro "exporter les données" de la feuille "import" vers "base"?

merci encore pour t'y être superbement bien "penché" et paf je pense que ce fil sera clôturé!

bonne soirée

Deps

Paf · 21 Novembre 2016

Re,

nouveau besoin, nouvelle discussion.

A +

XL 2010 créer des equipes mixtes

deps

XLDnaute Junior

Pièces jointes

Paf

XLDnaute Barbatruc

deps

XLDnaute Junior

Paf

XLDnaute Barbatruc

deps

XLDnaute Junior

Paf

XLDnaute Barbatruc

deps

XLDnaute Junior

deps

XLDnaute Junior

deps

XLDnaute Junior

Paf

XLDnaute Barbatruc

deps

XLDnaute Junior

Paf

XLDnaute Barbatruc

deps

XLDnaute Junior

deps

XLDnaute Junior

Pièces jointes

Paf

XLDnaute Barbatruc

Discussions similaires