Algorithmus für JederGegenJeden

Computer: Software & Programmierung Programmierung allgemein
#1

Hallöchen Experte :wink:

Ich hab ein Problem, welches mich nun schon seit Tagen beschäftigt.

Ich habe ein Excelsheet mit einer Tabelle jedergegenjeden für ein Turnier.

Die Tabelle kann 2-9 Spieler aufnehmen
Screenshot: http://s7.directupload.net/images/091126/efh8d4qy.jpg

Ich möchte nun per VBA die möglichen Spiele berechnen lassen, und zwar so, dass…

* jeder Spieler gegen jeden in seiner Gruppe 1x spielt
* dass die Spiele in der „angenehmsten“ Reihenfolge gespielt werden, also dass niemand 2x hintereinander dran ist…

Die Paarungen sollten in ein Array geschrieben werden können, damit ich sie in einem anderen Blatt auflisten kann.

Ausgangspunkt ist eine Funktion, in der ich die Spieler der Gruppe in ein Array SpielerGrp1() eintrage.

Wäre schön, wenn Du mir helfen könntest… ein Ansatz auch im Pseudo-Code würde schon genügen…

LG Micha

#2

Hallo,
ich habe einen VBA-Code geschrieben, der die
Paarungen ermittelt. Was nicht funzt, ist die
Sortierung (keiner soll 2x hintereinander spielen).
Hier versuche ich noch eine andere Lösung.
Aber hier erst einmal der Ansatz:

Gruß,
Ptonka

Sub paarungen()
'Matrix steht in A1:J10

'Letzten Eintrag in Spalte A ermitteln
LetzteZeile = [A65536].End(xlUp).Row
'Letzten Eintrag in Zeile 1 ermitteln
LetzteSpalte = Cells(1, Columns.Count).End(xlToLeft).Column

For z = 2 To LetzteZeile
TN1 = Cells(z, 1).Value
For s = 2 To LetzteSpalte
TN2 = Cells(1, s).Value
Select Case TN1
Case Is = TN2
GoTo weiter
End Select

Paarung = Cells(z, 1).Value & " - " & Cells(1, s).Value

LetzteZeile_L = [L65536].End(xlUp).Row

'ermittelte Paarung in Spalte L (ab Zeile 3) schreiben
Cells(LetzteZeile_L + 1, 12).Value = Paarung

Next s
weiter:
Next z

End Sub

#3

Hi PTonka,

Danke für Deinen Beitrag, das sieht ja schon recht vielversprechend aus!!!

ich weiss nicht, ob sich das mit dem 2x hintereinander spielen immer vermeiden lässt, aber es sollte schon so sein, das hier eine ausgeglichene Verteilung erfolgt. Wäre Super, wenn Dir da noch was zu einfällt!!!
lg micha, und eine tolle Woche noch…

#4

Hallo Micha,

ich habe den Code um 2 Prozeduren erweitert, um die
Doppeleinsätze zu verhindern. 100% funzt das zwar nicht, aber es ist ein Ansatz.
Versuche es mal damit:

Gruß,
Ptonka

Sub paarungen()
'Spalten L und M löschen
Columns(„L:M“).Select
Selection.ClearContents
Range(„L1“).Select

'Matrix steht in A1:J10

'Letzten Eintrag in Spalte A ermitteln
LetzteZeile = [A65536].End(xlUp).Row
'Letzten Eintrag in Zeile 1 ermitteln
LetzteSpalte = Cells(1, Columns.Count).End(xlToLeft).Column

For z = 2 To LetzteZeile
TN1 = Cells(z, 1).Value
For s = 2 To LetzteSpalte
TN2 = Cells(1, s).Value
Select Case TN1
Case Is = TN2
GoTo weiter
End Select

Paar1 = Cells(z, 1).Value
Paar2 = Cells(1, s).Value
Paarung = Paar1 & " - " & Paar2

LetzteZeile_L = [L65536].End(xlUp).Row

'ermittelte Paarung in Spalte L (ab Zeile 3) schreiben
Cells(LetzteZeile_L + 1, 12).Value = Paarung

Next s
weiter:
Next z
Range(„L1“).Value = „Paarungen nach Reihe“
Range(„M1“).Value = „Paarungen sortiert“

Call sort1
Call sort2
Range(„M1“).Select
End Sub

Sub sort1()
'Sortieren des jew. 1. gegen den jew. letzten
'Also der 1. in Spalte L gegen den Letzten der Spalte L
'dann der 2. in Spalte L gegen den vorletzten der Spalte L
'dann der 3. in Spalte L gegen den drittletzten der Spalte L u.s.w.
letzteZeile2 = [L65536].End(xlUp).Row

For i = 2 To letzteZeile2 / 2 + 1

Zähler = Zähler + 1
j = i + Zähler

If i = 2 Then
Cells(2, 13).Value = Cells(2, 12).Value
Zähler = 0
GoTo weiter
End If

Cells(j, 13).Value = Cells(i, 12).Value
weiter:
Next i

End Sub

Sub sort2()
letzteZeile2 = [L65536].End(xlUp).Row

For i = letzteZeile2 To letzteZeile2 / 2 + 1 Step -1

Zähler = Zähler + 1
j = i - Zähler

If i = letzteZeile2 Then
Cells(letzteZeile2, 13).Value = Cells(letzteZeile2, 12).Value
Zähler = 0
GoTo weiter
End If

Cells(j, 13).Value = Cells(i, 12).Value
weiter:
Next i

End Sub

#5

Hallöchen Ptonka,

Danke für den Tipp, ich versuch das mal so umzusetzen.

lg Micha