Spielpaarungen
01.04.2006 14:54:34
Reinhard
in Spalte A stehen x Spieler (A,B,C,D,E). Aus den Spielern will alle möglichen Spielpaarungen auflisten, so dass pro Spieltag alle einmal drankommen, abgesehen davon dass bei ungrader Anzahl einer frei hat.
Seit Tagen hänge ich an dieser Herausforderung fest. Bei online-excel erhielt ich eine Formellösung ( ( http://www.online-excel.de/fom/fo_read.php?f=1&bzh=0&h=9595#a123x ), aber die bringt mich nicht weiter. heute habe ich alle "normalen" lösungsansätze verworfen und probiere es durch Zufallsgenerierte Spielpaarungen
Ein Spieltag entspricht dann einem Block von Int(x/2) Zeilen.
In der ersten n-Schleife erzeuge ich für alle Blocks die möglichen Spieler,
also bei 5 Spielern erzeuge ich die Strings "ABCD" "ABCE" "ABDE" "ACDE" "BCDE".
In der zweiten n-Schleife hüpfe ich von Block zu Block und schreibe als Beispiel für Block1 A:B, darunter wird per Zufall in der While-Schleife einer der anderen Spieler eingetragen, solange bis ich einen finde der noch nicht spielt an dem Tag.
Das klappt aber nicht immer, (siehe unten) oftmals erscheint eine leere Zelle wo ein Buchstabe erscheinen muss. Mir absolut unerklärlich, da ich per Zufall einen Buchstaben aus z.B. "ABCD" auswähle, wie kommt dann "" raus?
Sub Erzeugen2()
Dim zei As Long, anz As Byte, n, möglich(), nn As Byte, Blockbeginn, pos, nnn As Byte, merk
Dim zufall
Const abc = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Columns("B:H").ClearContents
anz = Range("A65536").End(xlUp).Row
ReDim möglich(anz)
For n = anz To 1 Step -1
If anz / 2 = Int(anz / 2) Then
möglich(n) = Left(abc, anz)
Else
möglich(anz + 1 - n) = Left(abc, n - 1) & Mid(abc, n + 1, anz - n)
End If
Next n
For n = 1 To anz * (anz - 1) / 2 Step anz * (anz - 1) / 2 / anz
pos = pos + 1
Cells(n, 2) = Left(möglich(pos), 1)
Cells(n, 4) = Mid(möglich(pos), 2, 1)
For nn = 1 To anz * (anz - 1) / 2 / anz - 1
'MsgBox "in nn: " & Int(anz * Rnd) + 1
Cells(n + nn, 2) = Mid(möglich(pos), Int(anz * Rnd) + 1, 1)
While (Application.WorksheetFunction.CountIf(Range(Cells(n, 2), Cells(n + nn, 4)), Cells(n + nn, 2))) > 1
Cells(n + nn, 2) = Mid(möglich(pos), Int(anz * Rnd + 1), 1)
'MsgBox "in while: " & Int(anz * Rnd) + 1
Wend
Next nn
Next n
End Sub
Gruß
Reinhard
Tabellenblattname: Tabelle1
A B C D E
1 A A B ABCD
2 B
3 C A B ABCE
4 D
5 E A B ABDE
6
7 A C ACDE
8 D
9 B C BCDE
10 E
Tabelle eingefügt mit Reinhards Tabelleneinfüger Version 1.0