Anzeige
Archiv - Navigation
1700to1704
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

16 Mannschaften Auslosung mit gesetzten Spielern

16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 11:41:45
Alex
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

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 15:57:32
Alex
NACHTRAG:
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.
..... natürlich können die FREILOSE auch unter den ersten 16 Spielern in der Anmeldeliste stehen die auf keinen Fall zusammen gelost werden dürfen. Dann müsste eben FREILOS aus den oberen Teil (1-16) auf den untern Teil (7-32) treffen.
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 19:40:24
Alexander
https://www.herber.de/bbs/user/130791.xls
Vielleicht kann ein VAB-Genie mal die angehängte Tabelle nun ansehen! Habe es jetzt hinbekommen. 16 Gruppen mit 2 Teams sowie die Auslosung mit 32 Spieler zu machen.
Allerdings verteilt er mir als Gruppenkopf nur 1-8 Spieler und nicht bis 16. Des weiteren hat er nicht kapiert dass Text FREILOS grundsätzlich zusammengelost wird und nicht mit einem anderen Namen Spieler oder später dann Name,Vorname zusammengelost werden darf.
Bin schon ziemlich weit, aber hier setzten meine VAB Kenntnisse gänzlich aus. Für Hilfe wäre ich sehr dankbar!
Viele Grüße
Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 21:13:56
Rob
Hi Alex,
abgesehen davon, dass Du Deinen Code nicht gepostet hat, gehe ich stark davon aus, dass man es von Grund auf neu programmieren muss. Ich würde es mir mal anschauen. Nur ein Frage zu den Freilosen; wie ist zu verstehen, dass Freilose grundsätzlich zusammengelost werden müssen? Schreib mal ein Beispiel, wie es auszusehn hat. Außerdem kann ich nirgends Namen oder Vornamen in Deiner Tabelle sehen - hier steht lediglich Spieler 1, 2, 3 etc. !?
Grüße,
Rob
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 21:15:22
Alexander
Hi Rob,
in Ordnung. Werde meine Hausaufgaben morgen machen! ;O)
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 21:20:14
Rob
Ah so, Du hast ja Buttons eingebaut. Habe ich übersehen. Grins. Zu den Freilosen; die sollen verteilt auf Spieler 1-24/26 bzw 28 verteilt werden?
Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
08.07.2019 21:55:27
Alexander
Ja genau! Im Prinzip soll es halt (sofern notwendig) nur Paarungen FREILOS/FREILOS geben.
Freilos/Spieler ist nicht möglich!
Vorbehaltlich, dafür sorgen wir aber, dass wir bei der Spieleranzahl immer eine teilbare Anmeldung haben (also 8 10 12 14 16 18 usw.)
;O)
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

Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 11:43:08
Rob
Hi,
ich mal damit angefangen, dass die Spieler 1 bis 16 auf die Gruppenköpfe verteilt werden. Schau mal ob das so passt:

Option Explicit
Sub Auslosung()
'Verweis zu Microsoft Scripting Runtime für Dictionary
Dim Spieler1Bis16 As New Dictionary
Dim i As Integer, Zufallszahl As Integer
Dim Spieler As Range, Gruppenkoepfe As Range, r As Range
With Sheets("Tabelle1")
Set Spieler = .Range("C3:C34")
Set Gruppenkoepfe = Union(.Range("G5"), .Range("G7"), .Range("G10"), .Range("G12"), . _
Range("G15"), .Range("G17"), .Range("G20"), .Range("G22"), .Range("G25"), .Range("G27"), .Range("G30"), .Range("G32"), .Range("G35"), .Range("G37"), .Range("G40"), .Range("G42"))
End With
'Dictionary mit Spielern füllen
For i = 0 To 15
Spieler1Bis16.Add CStr(Sheets("Tabelle1").Cells(i + 3, 3)), i
Next i
'Gruppenköpfe Team 1 bis 16 zuweisen
For Each r In Gruppenkoepfe
Zufallszahl = ((Spieler1Bis16.Count - 1 + 1) * Rnd + 1) - 1
If Spieler1Bis16.Count  Zufallszahl Then
r = Spieler1Bis16.Keys(Zufallszahl)
Spieler1Bis16.Remove CStr(r)
Else
r = Spieler1Bis16.Keys(Zufallszahl - 1)
Spieler1Bis16.Remove CStr(r)
End If
Next r
End Sub

Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 12:44:25
Alex
Ja das sieht schon einmal gut aus. Und jetzt geht es eigentlich nur noch darum wenn TEXT "FREILOS" muss zufällige Losung auf "FREILOS". Also Freilso - Freilos = JA Spieler - Freilos = NEIN
Schon einmal vielen herzlichen Dank für deine generöse Hilfe! ;O)
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 20:47:40
Rob
Hi Alex,
ich habe jetzt noch die 'Gruppenkörper' mit den schwächeren Spielern zugewiesen (hatte heute kaum Zeit). Jetzt muss man "nur" noch die Freilose berücksichtigen. Das wird knifflig!

Option Explicit
Sub Auslosung()
'Verweis zu Microsoft Scripting Runtime für Dictionary
Dim Spieler1Bis32 As New Dictionary
Dim i As Integer, Freilose As Integer, Zufallszahl As Integer, AnzahlSpieler As Integer
Dim Spieler As Range, Gruppenkoepfe As Range, Gruppenkoerper As Range, r As Range
With Sheets("Tabelle1")
Set Spieler = .Range("C3:C34")
Set Gruppenkoepfe = Union(.Range("G5"), .Range("G7"), .Range("G10"), .Range("G12"), . _
Range("G15"), .Range("G17"), .Range("G20"), .Range("G22"), .Range("G25"), .Range("G27"), .Range("G30"), .Range("G32"), .Range("G35"), .Range("G37"), .Range("G40"), .Range("G42"))
Set Gruppenkoerper = Union(.Range("G6"), .Range("G8"), .Range("G11"), .Range("G13"), . _
Range("G16"), .Range("G18"), .Range("G21"), .Range("G23"), .Range("G26"), .Range("G28"), .Range("G31"), .Range("G33"), .Range("G36"), .Range("G38"), .Range("G41"), .Range("G43"))
End With
For Each r In Spieler
If r = "Freilos" Then
Freilose = Freilose + 1
End If
Next r
Select Case Freilose
Case 0
AnzahlSpieler = 31
Case 2
AnzahlSpieler = 29
Case 4
AnzahlSpieler = 27
Case 6
AnzahlSpieler = 25
Case 8
AnzahlSpieler = 23
End Select
'Dictionary mit Spielern 1 bis 32 füllen
For i = 0 To AnzahlSpieler
Spieler1Bis32.Add CStr(Sheets("Tabelle1").Cells(i + 3, 3)), i
Next i
'Die stärksten Spieler den Gruppenköpfen zuweisen - Spieler 1 bis 16
For Each r In Gruppenkoepfe
tryagain:
Zufallszahl = ((Spieler1Bis32.Count - 1) * Rnd + 1) - 1
If Spieler1Bis32.Items(Zufallszahl)  Zufallszahl Then
r = Spieler1Bis32.Keys(Zufallszahl)
Spieler1Bis32.Remove CStr(r)
Else
GoTo tryagain
End If
Next r
'Gruppenkoerper Spieler 17 bis 32 inklusive Freilose zuweisen
For Each r In Gruppenkoerper
Zufallszahl = ((Spieler1Bis32.Count - 1) * Rnd + 1) - 1
If Spieler1Bis32.Count > 0 And Spieler1Bis32.Count  Zufallszahl Then
r = Spieler1Bis32.Keys(Zufallszahl)
Spieler1Bis32.Remove CStr(r)
End If
Next r
End Sub

Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 21:02:35
Alexander
Kann mich nur verneigen und mich tausendmal für deinen Einsatz bedanken. Unser gemeinnütziges Turnier findet am Samstag statt. Es hat also noch nicht so hohe Brisanz.
Aber wie ich schon sagte meine VBA Kenntnisse sind sehr sehr limitiert. Wie baue ich das in die fertige Excel mit Macros ein?
Beste Grüße
Alex
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 21:43:12
Rob
Einfach den ganzen Code copy / paste in

Private Sub CommandButton1_Click()
einfügen. Wenn Du z.B. Entwicklertools / Entwurfsmodus aktivierst und auf den Button 'Auslosung' doppel-klickst, kommst Du auch direkt in oben genannten Click-Event.
Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 21:50:01
Alex
Excel Sheet und Alt F11?
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
09.07.2019 22:18:46
Rob
Ja genau. Und dann unter Tabelle1 (Tabelle1) im Projektexplorer findest Du als zweiten Event Deinen CommandButton1_Click!
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
10.07.2019 11:25:22
Rob
Hi Alex,
das mit den Freilosen ist doch etwas kniffliger und ich komme gerade nicht wirklich dazu. Vllt heute abend. Ich hab nochmal nen Bug für die Auslosung der Gruppenköpfe und Körper behoben. Sie nachfolgender Code. Die Freilose kannst Du zur Not erstmal händisch zuweisen. Abgesehen davon ist der Code noch etwas statisch, weil man von Konstanten ausgeht, d.h. 2, 4, 6 oder 8 Freilose. Wenn Du z.B. 3 Freilose hast, crashed das Makro. Wie gesagt; das müsste man auch noch anpassen.
PS: Wie ist Deine Mail-Adresse? Dann kann ich Dir das Makro auch zuschicken, weil die Thread hier im Forum nur ne beschränkte Lebensdauer haben.

Option Explicit
Sub Auslosung()
'Verweis zu Microsoft Scripting Runtime für Dictionary
Dim Spieler1Bis32 As New Dictionary
Dim i As Integer, Freilose As Integer, Zufallszahl As Integer, AnzahlSpieler As Integer
Dim Spieler As Range, Gruppenkoepfe As Range, Gruppenkoerper As Range, r As Range
With Sheets("Tabelle1")
Set Spieler = .Range("C3:C34")
Set Gruppenkoepfe = Union(.Range("G5"), .Range("G7"), .Range("G10"), .Range("G12"), . _
Range("G15"), .Range("G17"), .Range("G20"), .Range("G22"), .Range("G25"), .Range("G27"), .Range("G30"), .Range("G32"), .Range("G35"), .Range("G37"), .Range("G40"), .Range("G42"))
Set Gruppenkoerper = Union(.Range("G6"), .Range("G8"), .Range("G11"), .Range("G13"), . _
Range("G16"), .Range("G18"), .Range("G21"), .Range("G23"), .Range("G26"), .Range("G28"), .Range("G31"), .Range("G33"), .Range("G36"), .Range("G38"), .Range("G41"), .Range("G43"))
End With
'Auslosung löschen wenn Felder befüllt sind
If Not Gruppenkoepfe Is Nothing Or Not Gruppenkoerper Is Nothing Then
Gruppenkoepfe.ClearContents
Gruppenkoerper.ClearContents
End If
For Each r In Spieler
If r = "Freilos" Then
Freilose = Freilose + 1
End If
Next r
Select Case Freilose
Case 0
AnzahlSpieler = 31
Case 2
AnzahlSpieler = 29
Case 4
AnzahlSpieler = 27
Case 6
AnzahlSpieler = 25
Case 8
AnzahlSpieler = 23
End Select
'Dictionary mit Spielern 1 bis 32 füllen
For i = 0 To AnzahlSpieler
Spieler1Bis32.Add CStr(Sheets("Tabelle1").Cells(i + 3, 3)), i
Next i
'Die stärksten Spieler den Gruppenköpfen zuweisen - Spieler 1 bis 16
For Each r In Gruppenkoepfe
tryagain:
Zufallszahl = ((Spieler1Bis32.Count - 1) * Rnd + 1) - 1
If Spieler1Bis32.Items(Zufallszahl)  Zufallszahl Then
r = Spieler1Bis32.Keys(Zufallszahl)
Spieler1Bis32.Remove CStr(r)
Else
GoTo tryagain
End If
Next r
End Sub

Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
10.07.2019 11:44:56
Alex
Hallo Rob,
ich würde mich dann ohnehin gerne bei Dir erkenntlich zeigen und Dir eine "Kleinigkeit" auf dem Postweg zu schicken, wenn Du mir deine Adresse mitteilst.
Bitte sende die fertige Datei an freaklex(at)freakmail.de
Ich hab es übrigens (*schäm*) nicht hinbekommen die fertige Datei anhand deines Codes zum Laufen zu bringen!
Es wäre halt gut wenn die "Variable" im VAB-Editor bliebe, dass ich jederzeit die Anzahl der Gruppen sowie Teilnehmer jeder Gruppe nach Wunsch festlegen kann.
Herzlichen Dank schon einmal. ;O)
VG
Alex
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
10.07.2019 12:43:15
Rob
Hi Alex,
wenn Du die Anzahl der Gruppen und Teilnehmer noch zusätzlich als Variable haben möchtest, müsste man das auch noch anpassen. Derzeit ist das alles sehr statisch. Ich würde ehrlich gesagt einen komplett anderen Ansatz verfolgen ggf über eine Userform. Ich mach mir mal Gedanken.
Danke für das Angebot aber Geschenk muss nicht sein. Ist ja für nen gemeinnützigen Zweck.
Grüße,
Rob
Anzeige
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
10.07.2019 12:58:58
Alex
oh, dann ist das ganze doch "komplexer" als ich dachte. Ich dachte den Grundquellcode hätte man mit den vorhanden variablen verwenden können und dann eben noch die notwendigen Optionen einzubauen.
50% der Startgebühr für dieses "Dartturnier" gehen an gemeinnützige Zwecke.
AW: 16 Mannschaften Auslosung mit gesetzten Spielern
12.07.2019 19:11:54
Rob
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

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige