Paarungen ohne Wiederholungen

Hermann · 2021-08-31T12:31:40+00:00

Hallo, ich suche eine Möglichkeit aus einer Teilnehmerliste, bei der die Anzahl der Teilnehmer variieren kann, Paarungen für 6 Runden zu erzeugen. Die Anzahl der Paarungen muss sich nach der Anzahl der Spieler richten, d.h. je mehr Spieler, desto mehr Paarungen. Die Paarungen dürfen sich nicht wiederholen. Bei einer ungeraden Spieleranzahl darf sich der einzelne Spieler in den 6 Runden ebenfalls nicht wiederholen. Habt ihr hierzu eine Lösung? Danke im vorraus https://www.herber.de/bbs/user/147848.xlsx

Hallo Hermann,
ich war mal so frei und habe bisschen rum gespielt, um dein Vorhaben zu realisieren (hauptsächlich, weil mich das selbst interessiert und ich mit sowas eigentlich keine Erfahrung habe).
Aber wenn ich auch anderen (also dir) damit helfen kann, warum nicht :)
Also, du musst das "Const MaxRunden = 6" austauschen durch "Dim MaxRunden As Variant"
Und dann zusätzlich vor dem "Application.ScreenUpdating = False" folgendes einfügen:
MaxRunden = Application.InputBox(prompt:="Bitte eine Zahl eingeben.", Title:="Eingabe Zahl", Default:=6, Type:=1)
Bei Default kannst du eine beliebige Zahl eintragen, die von vornherein als Vorgabe in der Inputbox stehen soll.
Gruß Pierre
PS: Das rattert einige Sekunden.

Hi
noch ne Variante, die Dopplungen ausschließt und das bei einfachem Code.
die erste Runde wird rein zufällig ermittelt, die folgenden dann durch den Ringtausch wie in der Turnhalle: die Paare stehen sich gegenüber.
für die nächste Runde rutscht dann die linke Seite um eins nach oben und die rechte um eins nach unten und an Enden wird die Seite getauscht.
Allerdings brauchst du mindestens doppelt so viele Teilnehmer wie Runden gespielt werden:


Sub SpielePaarung2()
Dim anz As Long
Dim anz2 As Long
Dim i As Long, sp As Long
Dim arr, arr2, x, y
anz = WorksheetFunction.CountA(Columns(1))
ReDim arr(1 To anz)
'--- Teilnehmer einlesen
For i = 1 To anz
arr(i) = Cells(2 + i - 1, 1).Value
Next
'--- zufällige Anordnung erzeugen
For i = 1 To anz
x = arr(i)
y = WorksheetFunction.RandBetween(1, UBound(arr))
arr(i) = arr(y)
arr(y) = x
Next
anz2 = WorksheetFunction.RoundUp(anz / 2, 0)
ReDim arr2(1 To anz2, 1 To 2)
'--- Paarung erste Runde, obere Hälfte gegen untere Hälfte
For i = 1 To anz
arr2(((i - 1) Mod anz2) + 1, WorksheetFunction.RoundUp(i / anz2, 0)) = arr(i)
Next
Cells(3, 4).Resize(anz2, 2) = arr2
'--- weitere Runden durch Ringtausch
For sp = 2 To 6
y = arr2(1, 2)
x = arr2(anz2, 1)
For i = 1 To anz2 - 1
arr2(i, 2) = arr2(i + 1, 2)
Next
arr2(anz2, 2) = x
For i = anz2 To 2 Step -1
arr2(i, 1) = arr2(i - 1, 1)
Next
arr2(1, 1) = y
Cells(3, (sp - 1) * 3 + 4).Resize(anz2, 2) = arr2
Next
End Sub

Gruß Daniel

Forumthread: Paarungen ohne Wiederholungen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial