Sub ARRANGER()
If listeClub() Then MsgBox "Mission impossible !": End
Dim ta, tablo, temp
Dim i As Long, j As Long, k As Long, l As Long, c As Long
Dim t As Long
t = 2
With Me
ta = .Range("B7:D" & .Range("B65536").End(xlUp).Row)
l = UBound(ta, 1): c = UBound(ta, 2) + 1
ReDim Preserve ta(1 To l, 1 To c)
Do
tablo = ta
For i = 1 To l
tablo(i, c) = Rnd
Next i
For i = 1 To l
For j = 1 To l
If tablo(i, c) > tablo(j, c) Then
For k = 1 To c
temp = tablo(i, k)
tablo(i, k) = tablo(j, k)
tablo(j, k) = temp
Next k
End If
Next j
Next i
ReDim Preserve tablo(1 To l, 1 To c - 1)
For i = 3 To l
For j = i To l
If tablo(i - 1, 2) <> tablo(i - 2, 2) Or tablo(j, 2) <> tablo(i - 1, 2) Then Exit For [COLOR="Green"]'Version "pas plus de deux fois de suite le même club"[/COLOR]
[COLOR="Green"]' If tablo(j, 2) <> tablo(i - 1, 2) Then Exit For 'Version "pas deux fois de suite le même club"[/COLOR]
Next j
If j > l Then Exit For
For k = 1 To c - 1
temp = tablo(i, k)
tablo(i, k) = tablo(j, k)
tablo(j, k) = temp
Next k
Next i
Loop While tablo(l, 2) = tablo(l - 1, 2) And tablo(l - 1, 2) = tablo(l - 2, 2) [COLOR="Green"]'Version "pas plus de deux fois de suite le même club"[/COLOR]
[COLOR="Green"]' Loop While tablo(l, 2) = tablo(l - 1, 2) 'Version "pas deux fois de suite le même club"[/COLOR]
.Range("B7:D" & .Range("B65536").End(xlUp).Row) = tablo
End With
End Sub
Function listeClub()
Dim i As Long, j As Long
Dim ta, tc, tf As Boolean
ta = Me.Range("C7:C" & Me.Range("B65536").End(xlUp).Row)
tc = listCol(ta)
ReDim Preserve tc(1 To UBound(tc, 1), 1 To 2)
For i = 1 To UBound(tc, 1)
For j = 1 To UBound(ta, 1)
tc(i, 2) = tc(i, 2) - (ta(j, 1) = tc(i, 1))
Next j
tf = tf Or 3 * tc(i, 2) - 2 * UBound(ta, 1) - 2 > 0 [COLOR="Green"]'Version "pas plus de deux fois de suite le même club"[/COLOR]
[COLOR="Green"]' tf = tf Or 2 * tc(i, 2) - UBound(ta, 1) - 1 > 0 'Version "pas deux fois de suite le même club"[/COLOR]
Next i
listeClub = tf
End Function
Function listCol(tab2D) [COLOR="Green"]' ***
' REQUIS : 'transpose(tab2D)', 'listLin(tab2D)'
' Réduit un tableau à deux dimensions d'une seule colonne
' à la liste des valeurs distinctes de cette colonne.[/COLOR]
listCol = transpose(listLin(tab2D:=transpose(tab2D:=tab2D)))
End Function
Function listLin(tab2D) [COLOR="Green"]' ***
' Réduit un tableau à deux dimensions d'une seule ligne
' à la liste des valeurs distinctes de cette ligne.[/COLOR]
Dim i As Long, n As Long, s
n = 1
For Each s In tab2D
For i = 1 To n
If s = tab2D(1, i) Then Exit For
Next i
If i > n Then n = n + 1: tab2D(1, n) = s
Next s
ReDim Preserve tab2D(1 To 1, 1 To n)
listLin = tab2D
End Function
Function transpose(tab2D) [COLOR="Green"]'***
' Transpose un tableau à deux dimensions.[/COLOR]
Dim i As Long, j As Long, li As Long, lt As Long, ci As Long, ct As Long, u
li = LBound(tab2D, 1): lt = UBound(tab2D, 1): ci = LBound(tab2D, 2): ct = UBound(tab2D, 2)
ReDim u(ci To ct, li To lt)
For i = li To lt
For j = ci To ct
u(j, i) = tab2D(i, j)
Next j
Next i
transpose = u
End Function
