Hallo,
'k Had weining energie om piano te studeren - wellicht nawerking zomeruur -, dus even Excelitis laten opkomen...
In bijlage vind je een werkversie: doordat alles vlak naast elkaar staat heb je een goed overzicht van het effect. De voorwaardelijke opmaak toont ook welke ploegen 2 man hebben. Verder zit er nog voorwaardelijke opmaak (rood) om fouten te tonen (ploegen die geen 3 man hebben), beter gezegd om te laten zien dat alles OK is. Dit was erg handig tijdens het testen. Zo te zien is alles dus OK.
De "kleine ploegen" schuiven dus door. Voorbeeld: eerst bestaan ploegen 6 & 7 uit 2 man. Daarna 4 & 5, enzoverder.
Option Explicit
Sub VerdeelPloegen()
'Erik Van Geit
'070402
'code bevat geen errorhandling voor te klein aantal spelers
'GEGEVEN
'spelerlijst in A1:Ax (x = laatste rij)
'RESULTAAT
'random teamverdeling per 3, indien nodig per 2
'teamnummers in B1:Ix
'VOORBEELD
'speler 1 2 2 3 2 2 3 1
'speler 2 3 3 2 3 3 2 2
'speler 3 1 3 1 1 3 3 3
'speler 4 3 1 2 2 1 1 1
'speler 5 2 2 3 1 3 2 2
'speler 6 1 1 2 3 1 2 1
'speler 7 1 3 1 2 1 1 3
'speler 8 2 1 3 1 2 3 2
Dim cnt As Long, t3 As Long, t2 As Long
Dim arr As Variant
Dim i As Long, j As Long, k As Integer, l As Integer
'**** EDIT ****
Const ronden As Integer = 7
'**** END EDIT ****
'aantal ploegen van 2 en 3
cnt = Range("A" & Rows.Count).End(xlUp).Row
Select Case cnt Mod 3
Case 0: t3 = cnt / 3
Case 1: t3 = (cnt - 4) / 3: t2 = 2
Case 2: t3 = (cnt - 2) / 3: t2 = 1
End Select
'maak matrix
'voorbeeld: 1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 5, 5
ReDim arr(1 To cnt)
For j = 1 To t3
l = l + 1
For k = 1 To 3
i = i + 1
arr(i) = l
Next k
Next j
For j = 1 To t2
l = l + 1
For k = 1 To 2
i = i + 1
arr(i) = l
Next k
Next j
Application.ScreenUpdating = False
Columns("B:I").ClearContents
For i = 2 To ronden
'random sorteren matrix
Range(Cells(1, i), Cells(cnt, i)) = Application.Transpose(arrOut(arr))
'kleinste ploegen schuiven door
For j = 1 To cnt
arr(j) = IIf(arr(j) < t2 + 1, l, 0) + arr(j) - t2
Next j
Next i
Application.ScreenUpdating = True
End Sub
Private Function arrOut(arrIn As Variant) As Variant
Dim cnt As Long, i As Long, pick As Long
Dim temp As Variant
cnt = UBound(arrIn, 1)
ReDim temp(1 To cnt)
Randomize
For i = 1 To cnt
pick = Int(cnt * Rnd) + 1
temp(i) = arrIn(pick)
arrIn(pick) = arrIn(cnt)
arrIn(cnt) = temp(i)
cnt = cnt - 1
Next
arrOut = temp
End FunctionOm er meer van te begrijpen kan je de code doorlopen met functietoets F8. Neem dan een klein aantal spelers.
beste groeten,
Erik
