AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 22:16:33
Alexander
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