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