Macro tirage au sort

Le 17/03/2019 à 10:56

Bonjour

Au sein d'une amicale de pétanque j'utilise depuis au moins 10 ans

une macro pour effectuer des tirages d'équipes pour des tournois.

Cette macro fonctionne trés bien de 10 équipes à 128.

Mais avec 8 équipes la macro se plante une fois sur deux

et se plante toujours avec 6 ou 4 équipes.

J'ai tenté de trouver une solution mais mes connaissances en VBA

sont insuffisantes.

Quelqu'un pourrait -il m'aider à débloquer la situation et faire en sorte que

la macro fonctionne à partir de 4 équipes.

D'avance Merci

Pierre

52tirage-equipe-amicale.zip (15.18 Ko)
Le 17/03/2019 à 11:17

qu'appelles-tu "plantage"?

quand j'essaie, la macro continue sans jamais s’arrêter, mais pas de plantage.

je vois le soucis, je réfléchis comment le corriger.

Le 17/03/2019 à 12:18

j'appelle plantage le fait que la macro tourne sans s'arreter.

merci de ton aide

Pierre

Le 17/03/2019 à 13:42

voilà, j'ai une correction pour 8 équipes.

en dessous de 8, il faut changer les règles du tirage au sort, ou diminuer le nombre de tours.

si les équipes ne peuvent pas se rencontrer plus d'une fois, on ne peut avoir que 5 tours avec 6 équipes, et 3 tours avec 4 équipes.

Option Explicit
Const premiereligne As Long = 7
Const max_nombre_tours As Integer = 6

Sub SelectionAleatoireDesTours()
Dim num As Integer, i As Integer, j As Integer, k As Integer
Dim Deminum As Integer, NumeroLigne As Integer, SommeLigne As Integer, NumeroLigneACopier As Integer
Dim FinNumeroLigneACopier As Integer, VidageLigne As Integer
Dim NBequipe As Integer
Dim NBcolonne(12) As String
Dim NBTotalTirage As Integer, NBTirageTrouve As Integer, AncienNBTirageTrouve As Integer
Dim Tirage() As Integer, PremiereEquipe() As Integer, DeuxiemeEquipe() As Integer
Dim PremiereColonne As Boolean, TirageDejaPresent As Boolean
Dim pointeur() As Boolean
Dim nombre_essais As Long
Dim nombre_tours As Integer, limite_tours As Integer

'Initialisation
NBequipe = Worksheets("Feuil1").Range("G4").Value
Deminum = (NBequipe / 2)
Select Case 2 * Deminum
    Case 6:
        limite_tours = 5
    Case 4:
        limite_tours = 3
    Case Else:
        limite_tours = max_nombre_tours
End Select
If limite_tours < max_nombre_tours Then
    nombre_tours = limite_tours
Else
    nombre_tours = max_nombre_tours
End If

NBTotalTirage = Deminum * nombre_tours
NBTirageTrouve = 0
AncienNBTirageTrouve = 0
ReDim Tirage(NBTotalTirage)
ReDim PremiereEquipe(NBTotalTirage)
ReDim DeuxiemeEquipe(NBTotalTirage)
ReDim pointeur(NBequipe)
NBcolonne(1) = "A"
NBcolonne(2) = "B"
NBcolonne(3) = "C"
NBcolonne(4) = "D"
NBcolonne(5) = "E"
NBcolonne(6) = "F"
NBcolonne(7) = "G"
NBcolonne(8) = "H"
NBcolonne(9) = "I"
NBcolonne(10) = "J"
NBcolonne(11) = "K"
NBcolonne(12) = "L"
Deminum = (NBequipe / 2)
j = 1
NumeroLigne = premiereligne

nombre_essais = 0
While NBTirageTrouve < NBTotalTirage
If nombre_essais > 1000 Then
    NBTirageTrouve = 0
    AncienNBTirageTrouve = 0
    nombre_essais = 0
End If

'Test si tirage incomplet on supprime les lignes
'If (NBTirageTrouve <> 0) And (NBTirageTrouve <> Deminum) And (NBTirageTrouve <> (Deminum * 2)) And (NBTirageTrouve <> (Deminum * 3)) And _
(NBTirageTrouve <> (Deminum * 4)) And (NBTirageTrouve <> (Deminum * 5)) And (NBTirageTrouve <> (Deminum * 6)) Then
If (NBTirageTrouve Mod Deminum) <> 0 Then

    NBTirageTrouve = AncienNBTirageTrouve

    Range("A" & NumeroLigne & ":C1000").Select
    Selection.Delete

End If
NumeroLigne = NBTirageTrouve + premiereligne
AncienNBTirageTrouve = NBTirageTrouve

For i = 1 To NBequipe
    pointeur(i) = True
Next i
Randomize
PremiereColonne = True
For i = 1 To NBequipe

'Bloc pour tirage aleatoire
UnAutre:
    num = Int((NBequipe * Rnd) + 1)
    If pointeur(num) Then

        If PremiereColonne Then
            Worksheets("Feuil1").Range(NBcolonne(1) & NumeroLigne) = num
            PremiereColonne = False
        Else
            Worksheets("Feuil1").Range(NBcolonne(2) & NumeroLigne) = num
            SommeLigne = Worksheets("Feuil1").Range(NBcolonne(1) & NumeroLigne) + Worksheets("Feuil1").Range(NBcolonne(2) & NumeroLigne)
            TirageDejaPresent = False
            For k = 1 To NBTirageTrouve
                If SommeLigne = Tirage(k) And (num = PremiereEquipe(k) Or num = DeuxiemeEquipe(k)) Then
                    Worksheets("Feuil1").Range(NBcolonne(1) & NumeroLigne) = ""
                    Worksheets("Feuil1").Range(NBcolonne(2) & NumeroLigne) = ""
                    NumeroLigne = NumeroLigne - 1
                    TirageDejaPresent = True
                    Exit For
                End If
            Next k

            If TirageDejaPresent = False And NBTirageTrouve <> NBTotalTirage Then
                NBTirageTrouve = NBTirageTrouve + 1
                Tirage(NBTirageTrouve) = SommeLigne
                PremiereEquipe(NBTirageTrouve) = Worksheets("Feuil1").Range(NBcolonne(1) & NumeroLigne)
                DeuxiemeEquipe(NBTirageTrouve) = num
                Worksheets("Feuil1").Range(NBcolonne(3) & NumeroLigne) = SommeLigne
            Else
                Exit For
            End If
            NumeroLigne = NumeroLigne + 1
            PremiereColonne = True
        End If
        pointeur(num) = False
    Else
        GoTo UnAutre
    End If

Next i
nombre_essais = nombre_essais + 1
Wend

'----------------------------
'Mise en forme du tableau
'----------------------------
NumeroLigneACopier = premiereligne

'Deuxième tour
NumeroLigneACopier = NumeroLigneACopier + Deminum
VidageLigne = NumeroLigneACopier
FinNumeroLigneACopier = NumeroLigneACopier + (Deminum - 1)
Range("A" & NumeroLigneACopier & ":B" & FinNumeroLigneACopier).Select
Selection.Cut
Range("C7").Select
ActiveSheet.Paste

'Troisième tour
NumeroLigneACopier = NumeroLigneACopier + Deminum
FinNumeroLigneACopier = NumeroLigneACopier + (Deminum - 1)
Range("A" & NumeroLigneACopier & ":B" & FinNumeroLigneACopier).Select
Selection.Cut
Range("E7").Select
ActiveSheet.Paste

'Quatrième tour
NumeroLigneACopier = NumeroLigneACopier + Deminum
FinNumeroLigneACopier = NumeroLigneACopier + (Deminum - 1)
Range("A" & NumeroLigneACopier & ":B" & FinNumeroLigneACopier).Select
Selection.Cut
Range("G7").Select
ActiveSheet.Paste

'Cinquième tour
NumeroLigneACopier = NumeroLigneACopier + Deminum
FinNumeroLigneACopier = NumeroLigneACopier + (Deminum - 1)
Range("A" & NumeroLigneACopier & ":B" & FinNumeroLigneACopier).Select
Selection.Cut
Range("I7").Select
ActiveSheet.Paste

'Sixième tour
NumeroLigneACopier = NumeroLigneACopier + Deminum
FinNumeroLigneACopier = NumeroLigneACopier + (Deminum - 1)
Range("A" & NumeroLigneACopier & ":B" & FinNumeroLigneACopier).Select
Selection.Cut
Range("K7").Select
ActiveSheet.Paste

'Vidage des lignes restantes et formatage general
Range("A" & VidageLigne & ":L1000").Select
Selection.Delete
Range("A7:L" & VidageLigne - 1).Select
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    Range("A6:B" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("C6:D" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("E6:F" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("G6:H" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("I6:J" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("K6:L" & VidageLigne - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Range("A7").Select

End Sub

Sub CalculTirage_QuandClic()

    SelectionAleatoireDesTours

End Sub
Le 17/03/2019 à 15:00

Super

ça répond tout à fait à mon attente.

Lorsque je suis à 4 ou 6 équipes 2 tours me suffisent

Merci pour ton aide

Pierre

Rechercher des sujets similaires à "macro tirage sort"