Manschaftsauslosung für Kickerspiel

Hallo liebe VBA Profis,
Ich würde gerne für unseren "Kickerclub" eine brauchbare EXCEL-VBA Tabelle erstellen, mit der man
von 4 bis 16 Teilnehmen Doppelmanschaften bzw. 2er Teams erstellen kann.
Ich habe schon viele Beispiele hier im Forum gefunden und auch versucht diese Beispiele einzubinden.
Aber, da ich recht wenig mit VBA am Hut habe, komme ich nicht so richtig weiter.
Denn alle Beispiele aus diesem Forum beziehen sich leider meistens auf Einzelspieler gegen Einzelspieler.
Ich möchte aber gerne Manschaft (2er Teams) gegen Manschaft.
Die Aufteilung Jeder gegen Jeden klappt schonmal.
Ab hier fangen für mich die Probleme an. Durch die teilung in der horizontalen Mitte der Liste Jeder gegen Jeden könnte man schonmal per VBA die untere Hälfte neben die Obere Hälfte setzen und hat somit
zwei Teams nebeneinander, also erhält eine Liste mit vier Spalten.
in Spalte 1 und 2 gibt es keine doppelten Werte ebenso in Spalte 3 und 4.
Aber... Team 1 (Spalte 1 und 2) und Team 2 (Spalte 3 und 4) können gleiche Werte besitzen.
Ich hab das mit einer menge WennFormeln, Zufallszahl und zellkopierereien mühsam händisch auf dem Tabellenblatt hinbekommen, dass wirklich alle Teams jeder gegen jeden ohne doppelte Werte in der Spalte gelistet werden.
Ich habe hier die Mappe "Kickern_Teamauslosung" beigefügt.
Ich hoffe, dass hier jemand die Zeit findet mir mal etwas auf die Sprünge zu helfen so dass
ich damit weiter komme.
Mit besten Dank für eure Bemühungen: Gruß Ulli

Meine bisherige Datei:
https://www.herber.de/bbs/user/164916.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo, ich habe das mit dem Aufteilen mit dieser Formel gelöst.
Das klappt eigentlich "wunderbar"...

Sub Aufteilen()
Dim rng As Range
Dim InputRng As Range
Dim OutRng As Range
Dim xRow As Integer
Dim xCol As Integer
Dim xArr As Variant
Dim xTitleId As Variant

Dim i As Long
Dim xvalue As String
Dim irow As Long
Dim icol As Long
Dim yarr As Range

'Spalte in "A" teilen

Set InputRng = Application.Selection
Set InputRng = Range("b2:b" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row)
xRow = (ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row - 1) / 2
Set OutRng = Range("d1")
Set InputRng = InputRng.Columns(1)
xCol = InputRng.Cells.Count / xRow
ReDim xArr(1 To xRow, 1 To xCol + 1)
For i = 0 To InputRng.Cells.Count - 1
xvalue = InputRng.Cells(i + 1)
irow = i Mod xRow
icol = VBA.Int(i / xRow)
xArr(irow + 1, icol + 1) = xvalue
Next
OutRng.Resize(UBound(xArr, 1), UBound(xArr, 2)).Value = xArr

'Spalte in "B" teilen

Set InputRng = Application.Selection
Set InputRng = Range("c2:c" & ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row)
xRow = (ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row - 1) / 2
Set OutRng = Range("g1")
Set InputRng = InputRng.Columns(1)
xCol = InputRng.Cells.Count / xRow
ReDim xArr(1 To xRow, 1 To xCol + 1)
For i = 0 To InputRng.Cells.Count - 1
xvalue = InputRng.Cells(i + 1)
irow = i Mod xRow
icol = VBA.Int(i / xRow)
xArr(irow + 1, icol + 1) = xvalue
Next
OutRng.Resize(UBound(xArr, 1), UBound(xArr, 2)).Value = xArr
End Sub

Beliebteste Forumthreads (12 Monate)

Manschaftsauslosung für Kickerspiel

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Manschaftsauslosung für Kickerspiel

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread