Option Explicit
Const MaxDuree = 3 'temps en seconde max pour un tirage
Const MaxEssai = 10 'nombre de tirage max à tenter
Dim Echec As Boolean
Sub Tirages()
Dim i&
For i = 1 To MaxEssai
Application.StatusBar = "Essai n° " & i & " sur " & MaxEssai
Echec = False
UnTirage
If Not Echec Then '
MsgBox "Tirage réussi."
Application.StatusBar = False
Exit Sub
End If
Next i
MsgBox "Tirages infructueux. Veuillez relancer un autre tirage."
Application.StatusBar = False
End Sub
Sub UnTirage()
Dim tEqpe, i&, j&, k&, m&, compatible As Boolean, dico As New Dictionary, tgage, Deb
'Effacement des précédents résultats
Sheets("tirage au sort").Range("3:999").ClearContents
DoEvents
'Lecture du tableau Equipe
tEqpe = Sheets("Equipe").Range("a1").CurrentRegion
'création tableau Homme
ReDim tHom(1 To UBound(tEqpe) - 1)
For i = 2 To UBound(tEqpe): tHom(i - 1) = tEqpe(i, 2): Next
'création tableau Femme
ReDim tFem(1 To UBound(tEqpe, 2) - 2)
For j = 3 To UBound(tEqpe, 2): tFem(j - 2) = tEqpe(1, j): Next
'--------------- Les quatre tirages des hommes
Randomize: dico.CompareMode = TextCompare
Deb = Timer
For k = 1 To 4
dico.RemoveAll
'création du tableau des tirées au sort Homme en tenant compte des X
'et des binômes déjà utilisés
ReDim tiragehom(1 To UBound(tFem), 1 To 1)
For i = 1 To UBound(tFem)
compatible = False
Do
If Timer - Deb > MaxDuree Then
Echec = True
Exit Sub
End If
'on tire un homme au hasard (m est son rang)
m = 1 + Int(Rnd * UBound(tHom))
'on vérifie si compatible avec la femme de rang i
compatible = tEqpe(m + 1, i + 2) <> "X"
If compatible Then
If Not dico.Exists(CStr(m)) Then
dico.Add CStr(m), ""
tiragehom(i, 1) = tEqpe(m + 1, 2)
tEqpe(m + 1, i + 2) = "X"
Else
compatible = False
End If
End If
Loop Until compatible
Next i
Sheets("tirage au sort").Range("A3").Offset(, 4 * (k - 1)).Resize(UBound(tFem)) = Application.Transpose(tFem)
Sheets("tirage au sort").Range("B3").Offset(, 4 * (k - 1)).Resize(UBound(tFem)) = tiragehom
Next k
'--------------- tirage au sort des gages
'lecture du tableau des gages
tgage = Sheets("gages").Range("a1").CurrentRegion
For k = 1 To 4
For i = 1 To UBound(tFem)
m = 1 + Int(Rnd * UBound(tgage))
Cells(2 + i, 3 + 4 * (k - 1)) = tgage(m, 2)
Next i
Next k
Rows(3).Resize(UBound(tFem)).RowHeight = 10
Rows(3).Resize(UBound(tFem)).AutoFit
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim tgage, oldGage, newGage, n&
If Not Intersect(Target, Range("c:c,g:g,k:k,o:o")) Is Nothing Then
If Target.Row >= 3 Then
If Cells(Target.Row, "a") <> "" And Cells(Target.Row, "b") <> "" Then
oldGage = Cells(Target.Row, "c")
'lecture du tableau des gages
tgage = Sheets("gages").Range("a1").CurrentRegion
Randomize
Do
newGage = tgage(1 + Int(Rnd * UBound(tgage)), 2)
Loop Until newGage <> oldGage
Target = newGage
Cancel = True
End If
End If
End If
End Sub
