16 Mannschaften Auslosung mit gesetzten Spielern

Alex · 2019-07-08T11:41:45+00:00

Sehr geehrte Damen und Herren, liebe Forumsmitglieder, Möglichwerweise kann mir hier jemand helfen. Ich habe eine bereits bestehende Exceltabelle hier aus dem Forum entsprechend modifiziert. Komme aber nun nicht mehr weiter, die Ausspielung bleibt plötzlich stehen. Die Herausforderung für mich ist, dass die Ausspielung über 32 Einzelspieler laufen soll. Diese wiederum dann auf 16 Teams zusammengelost werden. Dabei sollen aber die ersten 16 Spieler in der Anmeldeliste links auf keinen Fall zusammen gelost werden (aufgrund Spielstärke). Des weiteren kann es sein, dass wir keine 32 Spieler (sondern nur 24 oder 26) haben zur Anmeldung und mit Freilosen aufgefüllt werden muss. Hier sollte die Auswertung automatisch erkennen dass "Freilose" immer als ein Team zusammengelost werden müssen. Es wäre prima, wenn mir hier jemand mit der VBA-Programmierung kurz helfen könnte. Ich denke es ist sind anhand meiner fast fertigen Datei nur noch eine Kleinigkeit, aber dafür fehlt mir ehrlich gesagt das KNOW-HOW. Herzlichen Dank für eine Antwort bzw. Hilfe! ;O) Hier der Link zur Datei: https://www.herber.de/bbs/user/130782.xls

Const AnzM = 32 'Anzahl der Spieler
Const AnzG = 8 'Anzahl der Gruppen
Const GrpGr = 2 'Gruppengrösse
Const Pause1 = 0.05 'Pause für Löstrommel
Const Pause2 = 1 'Pause nach erfolger Auslosung
Const Durchläufelostrommel = 32 'Duchläufe der Löstrommel

Private Sub CheckBox1_Click()
CommandButton1.Enabled = CheckBox1
CommandButton2.Enabled = CheckBox1
End Sub

Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, x As Integer, a As Integer
Dim Manschaften
Dim Max As Integer
Dim Pos(AnzM) As Integer
Dim Lostopf As Range
Dim Mannschaftsliste As Range
Dim Freie As Range
Dim Gesetzte As Range
Dim Gruppen As Range
Dim Los As Range
'--- Variablen
With Sheets("Tabelle1")
Set Lostopf = .Range("A3:C3").Resize(AnzM)
Set Mannschaftsliste = Lostopf.Columns(3)
Set Gesetze = Lostopf.Rows(1).Resize(AnzG)
Set Freie = Lostopf.Rows(AnzG + 1).Resize(AnzM - AnzG)
Set Gruppen = .Range("g5").Resize(AnzG * (GrpGr + 1))
Set Los = .Range("e3")
End With
For i = 1 To AnzG 'Postion in Gruppenliste für gesetzte Mannschaften zuweisen
Pos(i) = 1 + (i - 1) * (GrpGr + 1)
Next
j = -1 'Postion in Gruppenliste für Freie Mannschaften zuweisen
For i = AnzG + 1 To AnzM
j = j + 1
Select Case (j Mod (GrpGr + 1))
Case 0  'Leerzelle und gesetzte Mannschaft überspringen
j = j + 2
Case Else
End Select
Pos(i) = j
Next
'--- Auslosung vornehmen
Gruppen.ClearContents
With Lostopf.Columns(2)
.FormulaLocal = "=zufallszahl()"
.Formula = .Value
End With
Application.ScreenUpdating = False
Freie.Sort key1:=Freie.Cells(1, 2), order1:=xlAscending, header:=xlNo       'Freie  _
Mannschaften nach zufallsreihenfolge sortieren
Gesetze.Sort key1:=Gesetze.Cells(1, 2), order1:=xlAscending, header:=xlNo   'Gesetzte  _
Mannschaften nach Zufallsreihenfolge sortieren
Manschaften = Lostopf.Columns(3)                                            'Zufällig  _
sortierte MannListe in Array einlesen zur weiteren Verwendung
Lostopf.Sort key1:=Lostopf.Cells(1, 1), order1:=xlAscending, header:=xlNo   ' _
Mannschaftsliste wieder in die ursprüngliche sortierung bringen.
Lostopf.Columns(2).ClearContents                                            'Zufallszahlen  _
wieder löschen
Application.ScreenUpdating = True
'--- Mannschaften in Gruppen aufteilen ---
For i = 1 To AnzM
'--- Showteil Lostrommel durchlaufen lassen
Gruppen.Cells(Pos(i), 1).Interior.ColorIndex = 3
Max = AnzM
If i

Private Sub Warten(xx As Double)
Dim Zeit As Double
Zeit = Timer + xx
Do Until Timer > Zeit
Loop
End Sub

Private Sub CommandButton2_Click()
Dim i As Integer, j As Integer, x As Integer, a As Integer
Dim Manschaften
Dim Max As Integer
Dim Pos(AnzM) As Integer
Dim Lostopf As Range
Dim Mannschaftsliste As Range
Dim Freie As Range
Dim Gesetzte As Range
Dim Gruppen As Range
Dim Los As Range
'--- Variablen
With Sheets("Tabelle1")
Set Lostopf = .Range("A3:C3").Resize(AnzM)
Set Mannschaftsliste = Lostopf.Columns(3)
Set Gesetze = Lostopf.Rows(1).Resize(AnzG)
Set Freie = Lostopf.Rows(AnzG + 1).Resize(AnzM - AnzG)
Set Gruppen = .Range("g5").Resize(AnzG * (GrpGr + 1))
Set Los = .Range("e3")
End With
For i = 1 To AnzG 'Postion in Gruppenliste für gesetzte Mannschaften zuweisen
Pos(i) = 1 + (i - 1) * (GrpGr + 1)
Next
j = -1 'Postion in Gruppenliste für Freie Mannschaften zuweisen
For i = AnzG + 1 To AnzM
j = j + 1
Select Case (j Mod (GrpGr + 1))
Case 0  'Leerzelle und gesetzte Mannschaft überspringen
j = j + 2
Case Else
End Select
Pos(i) = j
Next
'--- Auslosung vornehmen
Gruppen.ClearContents
With Lostopf.Columns(2)
.FormulaLocal = "=zufallszahl()"
.Formula = .Value
End With
Application.ScreenUpdating = False
Freie.Sort key1:=Freie.Cells(1, 2), order1:=xlAscending, header:=xlNo       'Freie  _
Mannschaften nach zufallsreihenfolge sortieren
Gesetze.Sort key1:=Gesetze.Cells(1, 2), order1:=xlAscending, header:=xlNo   'Gesetzte  _
Mannschaften nach Zufallsreihenfolge sortieren
Manschaften = Lostopf.Columns(3)                                            'Zufällig  _
sortierte MannListe in Array einlesen zur weiteren Verwendung
Lostopf.Sort key1:=Lostopf.Cells(1, 1), order1:=xlAscending, header:=xlNo   ' _
Mannschaftsliste wieder in die ursprüngliche sortierung bringen.
Lostopf.Columns(2).ClearContents                                            'Zufallszahlen  _
wieder löschen
Application.ScreenUpdating = True
'--- Mannschaften in Gruppen aufteilen ---
For i = 1 To AnzM
Gruppen.Cells(Pos(i), 1).Value = Manschaften(i, 1)
Next
CheckBox1.Value = False
End Sub

Hi Alex,
hier ist der fertige Code (habe es Dir auch an Deine Mailadresse geschickt):


Option Explicit
Sub Auslosung2()
Dim r As Range, FindeFreilos As Range
Dim Zufallszahl As Integer, Counter As Integer, i As Integer
Dim AnzahlSpieler1Bis16 As Integer, AnzahlSpieler17Bis32 As Integer
Counter = 0
Dim AusgelosteSpieler(1 To 16)
'    Do Until AlleTeamsBesetzt = True
With Sheets("Tabelle1")
.Range("Team1Bis16").ClearContents
For Each r In .Range("Spieler1Bis32")
If IsEmpty(r) Then
r = "Freilos"
End If
Next r
.Columns("C:C").Font.Bold = False
On Error GoTo Gruppenkoerper
'Gruppenkoepfe mit stärksten Spielern zuweisen
AnzahlSpieler1Bis16 = AnzahlSpieler(.Range("Spieler1Bis16"))
Do Until Counter = AnzahlSpieler1Bis16
For i = 5 To 35 Step 2
Zufallszahl = ((16 - 1 + 1) * Rnd + 1)
If IsEmpty(.Cells(i, 7)) And .Cells(Zufallszahl + 4, 1)  "Freilos" And _
SpielerAusgelost(AusgelosteSpieler(), .Cells(Zufallszahl + 4, 3)) = False  _
Then
.Cells(i, 7) = .Cells(Zufallszahl + 4, 3)
.Cells(Zufallszahl + 4, 3).Font.Bold = True
Counter = Counter + 1
AusgelosteSpieler(Counter) = .Cells(Zufallszahl + 4, 3)
Else
'Freilose berücksichtigen
Set FindeFreilos = .Range("Spieler1Bis32").Find("Freilos")
If Not FindeFreilos Is Nothing Then
.Cells(i, 7) = "Freilos"
.Cells(i + 1, 7) = "Freilos"
.Cells(FindeFreilos.Row, 3).ClearContents
Set FindeFreilos = .Range("Spieler1Bis32").Find("Freilos")
If Not FindeFreilos Is Nothing Then
.Cells(FindeFreilos.Row, 3).ClearContents
End If
End If
End If
Next i
Loop
Gruppenkoerper:
'Gruppenkoerper mit verbliebenen Spielern zuweisen
Counter = 0
Erase AusgelosteSpieler
AnzahlSpieler17Bis32 = AnzahlSpieler(.Range("Spieler17Bis32"))
Do Until Counter = AnzahlSpieler17Bis32
For i = 6 To 36 Step 2
Zufallszahl = ((16 - 1 + 1) * Rnd + 1)
If IsEmpty(.Cells(i, 7)) And .Cells(Zufallszahl + 20, 1) > 16 And _
.Cells(Zufallszahl + 20, 3)  "Freilos" And .Cells(i - 1, 7).Text  "Freilos"  _
And _
SpielerAusgelost(AusgelosteSpieler(), .Cells(Zufallszahl + 20, 3)) = False  _
Then
.Cells(i, 7) = .Cells(Zufallszahl + 20, 3)
.Cells(Zufallszahl + 20, 3).Font.Bold = True
Counter = Counter + 1
AusgelosteSpieler(Counter) = .Cells(Zufallszahl + 20, 3)
End If
Next i
Loop
'Freilose wieder zuweisen
For Each r In .Range("Spieler1Bis32")
If IsEmpty(r) Then
r = "Freilos"
End If
Next r
End With
End Sub
Private Function SpielerAusgelost(ByRef SpielerArray(), ByRef Spieler As Variant) As Boolean
Dim x As Integer
For x = LBound(SpielerArray) To UBound(SpielerArray)
If SpielerArray(x) = Spieler Then
SpielerAusgelost = True
End If
Next x
End Function
Private Function AlleTeamsBesetzt() As Boolean
Dim r As Range
For Each r In Sheets("Tabelle1").Range("Team1Bis16")
If IsEmpty(r) Then
AlleTeamsBesetzt = False
Exit Function
Else
AlleTeamsBesetzt = True
End If
Next r
End Function
Private Function AnzahlSpieler(ByVal SpielerRange As Range) As Integer
Dim r As Range
Dim AnzahlFreilose As Integer
For Each r In SpielerRange
If r.Text  "Freilos" And Not IsEmpty(r) Then
AnzahlSpieler = AnzahlSpieler + 1
ElseIf r.Text = "Freilos" Then
AnzahlFreilose = AnzahlFreilose + 1
End If
Next r
Select Case AnzahlFreilose
Case Is = 1
AnzahlFreilose = WorksheetFunction.RoundUp(AnzahlFreilose \ 2, 0)
AnzahlSpieler = AnzahlSpieler + AnzahlFreilose
Case Is = 0
AnzahlSpieler = AnzahlSpieler
Case Is > 1
AnzahlSpieler = AnzahlSpieler + AnzahlFreilose \ 2 - 1
End Select
End Function

16 Mannschaften Auslosung mit gesetzten Spielern

Forumthread: 16 Mannschaften Auslosung mit gesetzten Spielern

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial