AW: Auslosung von Spielpaarungen
01.06.2006 12:40:45
Spielpaarungen
Hi Jürgen,
mit den 8 gesetzten Spielern klappt die Auslosung oft nicht im ersten Durchlauf.
Deshalb habe ich ein Makro davor gestellt, das die Auslosung in einer Schleife startet,
bis ein Ergebnis erzielt wurde:
Sub AuslosungStart()
Dim ii, fertig As Boolean
For ii = 1 To 50
AuslosungGruppenVereineGesetzt fertig
If fertig Then
' MsgBox "Fertig beim " & ii & ". Durchlauf"
Exit For
End If
Next ii
If ii > 50 Then MsgBox "Neustart erforderlich - noch kein Ergebnis"
End Sub
Sub AuslosungGruppenVereineGesetzt(erg As Boolean)
' Mangel: Spieler aus den kleinen Vereinen sind nie in der selben Gruppe
' Mögliche Abhilfe: Nicht zeilenweise, sondern diagonal füllen
Dim lngLast As Long, zz As Long, ii As Integer, rg As Range, str As String
Dim Valt As String, intLast As Integer, gg As Integer, arrV() As Integer
Dim anzV As Integer, arrG() As Integer, minG As Integer, kk As Long
Const AnzGr = 8 ' Anzahl Gruppen (max. 125, mind. Spieleranzahl des größten Vereins)
' (z. B. mit AnzGr = Spieleranzahl / 2 werden Paare ermittelt)
Randomize
ReDim arrG(1 To AnzGr)
Columns("J:IV").Clear
lngLast = Range("C" & Rows.Count).End(xlUp).Row
str = "C2:C" & lngLast
anzV = Evaluate( _
"SUM(IF(" & str & "<>"""",MATCH(" & str & "," & str & ",0)=ROW(1:" & lngLast - 1 & "))*1)")
ReDim arrV(1 To anzV)
For zz = 2 To lngLast
If IsEmpty(Cells(zz, "G")) Then
kk = kk + 1
Cells(kk, "K") = Cells(zz, "B")
Cells(kk, "L") = Cells(zz, "C")
Else
Cells(2, Cells(zz, "G") * 2 + 13) = Cells(zz, "B")
Cells(2, Cells(zz, "G") * 2 + 14) = Cells(zz, "C")
End If
Next zz
Columns("K:L").Sort Key1:=Range("L1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
lngLast = lngLast - 1
For zz = 1 To lngLast
If Valt <> Cells(zz, "L") Then
Valt = Cells(zz, "L")
gg = gg + 1
arrV(gg) = WorksheetFunction.CountIf(Columns("C"), Valt)
If arrV(gg) > AnzGr Then
MsgBox Valt & " hat mehr Spieler als es Gruppen gibt!"
Exit Sub
End If
End If
Next zz
gg = 0
lngLast = Range("L" & Rows.Count).End(xlUp).Row
For zz = 1 To lngLast
If Valt <> Cells(zz, "L") Then
Valt = Cells(zz, "L")
gg = gg + 1
End If
Cells(zz, "M") = arrV(gg)
Next zz
If lngLast > AnzGr * Int(lngLast / AnzGr) Then
For zz = lngLast + 1 To AnzGr * (Int(lngLast / AnzGr) + 1)
Cells(zz, "K") = "<kein>"
Cells(zz, "L") = "<FREI>"
Cells(zz, "M") = 999
Next zz
End If
Columns("K:M").Sort _
Key1:=Range("M1"), Order1:=xlDescending, _
Key2:=Range("L1"), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
gg = 0
Valt = ""
For zz = 1 To AnzGr
Cells(1, zz * 2 + 13) = "Gruppe " & zz
Next zz
For zz = 1 To lngLast
kk = 0
For ii = 1 To AnzGr
If arrG(ii) = minG And WorksheetFunction.CountIf _
(Columns(ii * 2 + 14), Cells(zz, "L")) = 0 Then kk = kk + 1
Next ii
On Error GoTo XEND
ReDim arrV(1 To kk)
On Error GoTo 0
kk = 0
For ii = 1 To AnzGr
If arrG(ii) = minG And WorksheetFunction.CountIf _
(Columns(ii * 2 + 14), Cells(zz, "L")) = 0 Then
kk = kk + 1
arrV(kk) = ii
End If
Next ii
gg = arrV(Rnd * (kk - 1) + 1)
intLast = Cells(Rows.Count, gg * 2 + 13).End(xlUp).Row + 1
Range(Cells(zz, "K"), Cells(zz, "L")).Copy Cells(intLast, gg * 2 + 13)
arrG(gg) = arrG(gg) + 1
minG = WorksheetFunction.Min(arrG)
Next zz
For Each rg In Range(Cells(2, "O"), Cells(lngLast / AnzGr + 1, AnzGr * 2 + 13))
If rg = "<kein>" Then
rg = Cells(lngLast / AnzGr + 1, rg.Column)
rg.Offset(0, 1) = Cells(lngLast / AnzGr + 1, rg.Column + 1)
Cells(lngLast / AnzGr + 1, rg.Column).ClearContents
Cells(lngLast / AnzGr + 1, rg.Column + 1).ClearContents
End If
Next rg
Rows(1).Font.Bold = True
zz = 2
While Not IsEmpty(Cells(zz, "O"))
Cells(zz, "J") = "Pos " & zz - 1
zz = zz + 1
Wend
Columns("K:N").Delete
erg = True
Exit Sub
XEND:
erg = False
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort