Paarungen ohne Wiederholungen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Paarungen ohne Wiederholungen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread