Const Sh1$ = "Qualif ", Sh2$ = "Planning Période ", fnR% = 3, fpC% = 2, Lg% = 6, Co% = 3, eLg% = 7, eCo% = 4
Dim Ta(), Tb%(), Tc%()
'fnR=1ere ligne des noms feuilles Sh1
'fpC=derniere colonne avant colonne période 1 des feuilles Sh2
'Lg/Co nb de lignes/colonnes par équipe
'eLg/eCo nb d'équipes par lignes/nb de lignes d'équipes
Sub Test()
Dim a&, i&, b&, j&, d&, e%(), f%(), c&, g&, h As Boolean, w As Worksheet, k%, x%, y%, lig%, col%
If ShNb(Sh1) <> 3 Then MsgBox "Nombre de feuilles " & Sh1 & "<> 3": Exit Sub
a = ShNb(Sh2)
If a = 0 Then MsgBox "Feuille " & Sh2 & "1 non trouvée": Exit Sub
Randomize
For i = 1 To a
Call Menage(i): Call Inventaire(i): b = UBound(Ta, 2): ReDim Tb(1 To 3)
For j = 1 To b: Tb(Ta(0, j)) = Tb(Ta(0, j)) + 1: Next j
d = TeamMaxNb
If d = 0 Then MsgBox "Aucune équipe posible pour la période " & i: GoTo Line1
e = CbNthTab(Tb(1), d, Int(CombinNb(Tb(1), d) * Rnd) + 1): f = CbComp(e, Tb(1)): Erase e
For j = 1 To UBound(f): Ta(0, f(j)) = 2: Next j
Erase f
Tb(2) = Tb(2) + Tb(1) - d: e = CbNthTab(Tb(2), 2 * d, Int(CombinNb(Tb(2), 2 * d) * Rnd) + 1): c = 0: g = 1
For j = 1 To d + Tb(2)
If Ta(0, j) = 2 Then
c = c + 1
If g > 2 * d Then
Ta(0, j) = 3
ElseIf e(g) <> c Then
Ta(0, j) = 3
Else
g = g + 1
End If
End If
Next j
Tb(3) = b - 3 * d: e = CbNthTab(Tb(3), d, Int(CombinNb(Tb(3), d) * Rnd) + 1): c = 0: g = 1
For j = 1 To b
If Ta(0, j) = 3 Then
c = c + 1
If g > d Then
Ta(0, j) = 0
ElseIf e(g) <> c Then
Ta(0, j) = 0
Else
g = g + 1
End If
End If
Next j
ReDim e(3): ReDim Tc(2, 1 To 2 * d)
For j = 1 To b: e(Ta(0, j)) = e(Ta(0, j)) + 1: h = Ta(0, j) = 3: Tc(Ta(0, j) + 2 * h, -h * d + e(Ta(0, j))) = j: Next j
Set w = Worksheets(Sh2 & i)
For j = 1 To d
x = Int(j / eLg): y = j Mod eLg: lig = x + 1 + (y = 0): col = y + -eLg * (y = 0): lig = (lig - 1) * Lg + 2: col = (col - 1) * Co + 2
Do: e = CbNthTab(d, 1, Int(d * Rnd) + 1): Loop Until Tc(1, e(1)) > 0
For k = 1 To 2: w.Cells(lig, col + k - 1) = Ta(k, Tc(1, e(1))): Next k
Tc(1, e(1)) = 0
Do: e = CbNthTab(2 * d, 2, Int(2 * d * (2 * d - 1) / 2 * Rnd) + 1): Loop Until Tc(2, e(1)) * Tc(2, e(2)) > 0
For k = 1 To 2: w.Cells(lig + 1, col + k - 1) = Ta(k, Tc(2, e(1))): w.Cells(lig + 2, col + k - 1) = Ta(k, Tc(2, e(2))): Next k
For k = 1 To 2: Tc(2, e(k)) = 0: Next k
Do: e = CbNthTab(d, 1, Int(d * Rnd) + 1): Loop Until Tc(1, d + e(1)) > 0
For k = 1 To 2: w.Cells(lig + 3, col + k - 1) = Ta(k, Tc(1, d + e(1))): Next k
Tc(1, d + e(1)) = 0
Next j
Line1:
Next i
End Sub
Private Function TeamMaxNb() As Long
Dim t&(), i&, j&, u&, a&, b&, k%
ReDim t(1 To 3, 1 To 1)
For i = 1 To 3: t(i, 1) = Tb(i): Next i
ReDim Preserve t(1 To 3, 1 To Tb(1))
For i = 2 To Tb(1): For j = 1 To 3: t(j, i) = t(j, i - 1) + (j = 1) - (j > 1) * (3 - j): Next j, i
For i = 1 To Tb(1)
u = UBound(t, 2): ReDim Preserve t(1 To 3, 1 To u + t(2, i) - 1)
For j = 1 To 3: t(j, u + 1) = t(j, i) + (j > 1) - 2 * (j > 2): Next j
For j = 3 To t(2, i): For k = 1 To 3: t(k, u + j - 1) = t(k, u + j - 2) + (k > 1) - 2 * (k > 2)
Next k, j, i
For i = 1 To UBound(t, 2)
a = t(1, i): b = Int(t(2, i) / 2)
If b < a Then a = b
If t(3, i) < a Then a = t(3, i)
If a > TeamMaxNb Then TeamMaxNb = a
Next i
End Function
Private Sub Inventaire(ByVal Per%)
Dim i%, w As Worksheet, c&, r&, j&, k%
ReDim Ta(2, 0)
For i = 1 To 3
Set w = Worksheets(Sh1 & i): r = w.Cells(Rows.Count, 1).End(xlUp).Row
If r < fnR Then ReDim Ta(0): Exit Sub
For j = fnR To r
If w.Cells(j, fpC + Per) = "X" Then
c = c + 1: ReDim Preserve Ta(2, c): Ta(0, c) = i
For k = 1 To 2: Ta(k, c) = w.Cells(j, k): Next k
End If
Next j, i
End Sub
Private Sub Menage(ByVal Sh&)
Dim w As Worksheet, i%, j%
Set w = Worksheets(Sh2 & Sh)
For i = 1 To eCo: For j = 1 To eLg: w.Range(w.Cells((i - 1) * Lg + 2, (j - 1) * Co + 2), w.Cells(i * Lg - 1, j * Co)).ClearContents: Next j, i
End Sub
Private Function ShNb(ByVal Nm$) As Long
Dim i&, w As Worksheet
On Error GoTo LineEnd
For i = 1 To Worksheets.Count: Set w = Worksheets(Nm & i): Next i
LineEnd:
ShNb = i - 1
End Function
Private Function CbNthTab(ByVal a&, ByVal b&, ByVal n#) As Integer()
Dim Tb&(), i&, x#, d&, Tf%()
ReDim Tb(b)
Do
d = d + 1: x = 0
For i = a - 1 - Tb(d - 1) To b - d Step -1
x = x + CombinNb(i, b - d)
If Not n > x Then Exit For
Next i
Tb(d) = a - i: n = n - x + CombinNb(i, b - d)
Loop Until d = b
ReDim Tf(1 To b)
For i = 1 To b: Tf(i) = Tb(i): Next i
CbNthTab = Tf
End Function
Private Function CombinNb(ByVal a%, ByVal b%) As Double
Dim c%
c = a - b
If b < c Then c = b
If c = 0 Then CombinNb = 1 Else CombinNb = MathFactoriel(a, c) / MathFactoriel(c)
End Function
Private Function MathFactoriel(ByVal Nb%, Optional Iter% = 0) As Double
Dim i&, n&
If Iter = 0 Then Iter = Nb
MathFactoriel = 1
For i = 0 To Iter - 1: MathFactoriel = MathFactoriel * (Nb - i): Next i
End Function
Private Function CbComp(Cb%(), a%) As Integer()
Dim b&, c&, u&, Tb%(), i&, j&
u = UBound(Cb): b = a - u: ReDim Tb(1 To b)
For j = 1 To Cb(1) - 1: Tb(j) = j: Next j
c = j - 1
For i = 2 To UBound(Cb): For j = Cb(i - 1) + 1 To Cb(i) - 1: c = c + 1: Tb(c) = j: Next j, i
For j = Cb(u) + 1 To a: Tb(c + j - Cb(u)) = j: Next j
CbComp = Tb
End Function
