| Arbeitsblatt mit dem Namen 'Start' | ||
| A | B | |
| 1 | ||
| 2 | Spieler | 8 |
| 3 | Plätze | 2 |
| 4 | ||
| 5 | Namen | |
| 6 | UweD | |
| 7 | Er | |
| 8 | Ich | |
| 9 | Sie | |
| 10 | Er Auch | |
| 11 | Isabella | |
| 12 | Caro | |
| 13 | Noch Jemand | |
| 14 | ||
| Zelle | Formel |
| B2 | =ANZAHL2(A6:A100) |
| Arbeitsblatt mit dem Namen 'Spielplan' | ||||||||||
| A | B | C | D | E | F | G | H | I | J | |
| 1 | Runde | Match | Spieler 1 | Spieler 2 | Platz | Slot (Spiele parallel) | Punkte Team 1 | Punkte Team 2 | Sieg: 1 Punkt; Niederlage: 0 Punkte | |
| 2 | 1 | 1 | UweD | Noch Jemand | Platz 1 | 1 | 1 | 0 | ||
| 3 | 1 | 2 | Er | Caro | Platz 2 | 1 | 1 | 0 | ||
| 4 | 1 | 3 | Ich | Isabella | Platz 1 | 2 | 1 | 0 | ||
| 5 | 1 | 4 | Sie | Er Auch | Platz 2 | 2 | 1 | 0 | ||
| 6 | 2 | 1 | UweD | Caro | Platz 1 | 1 | 1 | 0 | ||
| 7 | 2 | 2 | Noch Jemand | Isabella | Platz 2 | 1 | 1 | 0 | ||
| 8 | 2 | 3 | Er | Er Auch | Platz 1 | 2 | 1 | 0 | ||
| 9 | 2 | 4 | Ich | Sie | Platz 2 | 2 | 1 | 0 | ||
| 10 | 3 | 1 | UweD | Isabella | Platz 1 | 1 | 0 | 1 | ||
| 11 | 3 | 2 | Caro | Er Auch | Platz 2 | 1 | 0 | 1 | ||
| 12 | 3 | 3 | Noch Jemand | Sie | Platz 1 | 2 | 0 | 1 | ||
| 13 | 3 | 4 | Er | Ich | Platz 2 | 2 | 0 | 1 | ||
| 14 | 4 | 1 | UweD | Er Auch | Platz 1 | 1 | 0 | 1 | ||
| 15 | 4 | 2 | Isabella | Sie | Platz 2 | 1 | 0 | 1 | ||
| 16 | 4 | 3 | Caro | Ich | Platz 1 | 2 | 0 | 1 | ||
| 17 | 4 | 4 | Noch Jemand | Er | Platz 2 | 2 | 0 | 1 | ||
| 18 | 5 | 1 | UweD | Sie | Platz 1 | 1 | 0 | 1 | ||
| 19 | 5 | 2 | Er Auch | Ich | Platz 2 | 1 | 0 | 1 | ||
| 20 | 5 | 3 | Isabella | Er | Platz 1 | 2 | 0 | 1 | ||
| 21 | 5 | 4 | Caro | Noch Jemand | Platz 2 | 2 | 0 | 1 | ||
| 22 | 6 | 1 | UweD | Ich | Platz 1 | 1 | 0 | 1 | ||
| 23 | 6 | 2 | Sie | Er | Platz 2 | 1 | 0 | 1 | ||
| 24 | 6 | 3 | Er Auch | Noch Jemand | Platz 1 | 2 | 0 | 1 | ||
| 25 | 6 | 4 | Isabella | Caro | Platz 2 | 2 | 1 | 0 | ||
| 26 | 7 | 1 | UweD | Er | Platz 1 | 1 | 1 | 0 | ||
| 27 | 7 | 2 | Ich | Noch Jemand | Platz 2 | 1 | 1 | 0 | ||
| 28 | 7 | 3 | Sie | Caro | Platz 1 | 2 | 1 | 0 | ||
| 29 | 7 | 4 | Er Auch | Isabella | Platz 2 | 2 | 1 | 0 | ||
| Arbeitsblatt mit dem Namen 'Rangliste' | |||
| A | B | C | |
| 1 | Spieler | Punkte | Differenz |
| 2 | Ich | 7 | 7 |
| 3 | Er | 5 | 3 |
| 4 | Sie | 5 | 3 |
| 5 | UweD | 3 | -1 |
| 6 | Noch Jemand | 3 | -1 |
| 7 | Er Auch | 3 | -1 |
| 8 | Isabella | 2 | -3 |
| 9 | Caro | 0 | -7 |
Option Explicit
Sub TurnierErstellen()
Dim wsStart As Worksheet
Dim wsPlan As Worksheet
Dim n As Long, plaetze As Long
Dim i As Long, j As Long, r As Long
Dim players() As String
Dim rowOut As Long
Dim arr As Variant
Dim temp As String
Set wsStart = ThisWorkbook.Sheets("Start")
n = wsStart.Range("B2").Value
plaetze = wsStart.Range("B3").Value
ReDim players(1 To n)
For i = 1 To n
players(i) = wsStart.Cells(i + 5, 1).Value
Next i
' Spielplan Sheet
On Error Resume Next
Set wsPlan = ThisWorkbook.Sheets("Spielplan")
On Error GoTo 0
wsPlan.Cells.Clear
wsPlan.Range("A1:J1") = Array("Runde", "Match", "Spieler 1", _
"Spieler 2", "Platz", "Slot (Spiele parallel)", "Punkte Team 1", "Punkte Team 2", _
"", "Sieg: 1 Punkt; Niederlage: 0 Punkte")
rowOut = 2
' Round Robin (simple rotation)
For i = 1 To n - 1
For j = 1 To n / 2
Dim p1 As String, p2 As String
p1 = players(j)
p2 = players(n - j + 1)
wsPlan.Cells(rowOut, 1).Value = i
wsPlan.Cells(rowOut, 2).Value = j
wsPlan.Cells(rowOut, 3).Value = p1
wsPlan.Cells(rowOut, 4).Value = p2
wsPlan.Cells(rowOut, 5).Value = "Platz " & ((j - 1) Mod plaetze + 1)
wsPlan.Cells(rowOut, 6).Value = Int((j - 1) / plaetze) + 1
rowOut = rowOut + 1
Next j
' rotate players
temp = players(n)
For j = n To 3 Step -1
players(j) = players(j - 1)
Next j
players(2) = temp
Next i
MsgBox "Turnierplan erstellt!", vbInformation
wsPlan.Activate
End Sub
Sub RanglisteBoule()
Dim wsPlan As Worksheet, wsRank As Worksheet
Dim lastRow As Long, i As Long
Dim pts As Object, diff As Object
Set pts = CreateObject("Scripting.Dictionary")
Set diff = CreateObject("Scripting.Dictionary")
Set wsPlan = ThisWorkbook.Sheets("Spielplan")
lastRow = wsPlan.Cells(wsPlan.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
Dim p1 As String, p2 As String
Dim s1 As Variant, s2 As Variant
p1 = wsPlan.Cells(i, 3).Value
p2 = wsPlan.Cells(i, 4).Value
s1 = wsPlan.Cells(i, 7).Value
s2 = wsPlan.Cells(i, 8).Value
If p1 = "" Or p2 = "" Then GoTo skip
If Not pts.exists(p1) Then pts(p1) = 0
If Not pts.exists(p2) Then pts(p2) = 0
If Not diff.exists(p1) Then diff(p1) = 0
If Not diff.exists(p2) Then diff(p2) = 0
If IsNumeric(s1) And IsNumeric(s2) Then
' Punkte zählen
If s1 > s2 Then
pts(p1) = pts(p1) + 1
ElseIf s2 > s1 Then
pts(p2) = pts(p2) + 1
Else
' Unentschieden (falls erlaubt)
pts(p1) = pts(p1) + 0.5
pts(p2) = pts(p2) + 0.5
End If
' Differenz (Boule entscheidend!)
diff(p1) = diff(p1) + (s1 - s2)
diff(p2) = diff(p2) + (s2 - s1)
End If
skip:
Next i
' Rangliste erstellen
On Error Resume Next
Set wsRank = ThisWorkbook.Sheets("Rangliste")
On Error GoTo 0
If wsRank Is Nothing Then
Set wsRank = ThisWorkbook.Sheets.Add
wsRank.Name = "Rangliste"
End If
wsRank.Cells.Clear
wsRank.Range("A1:C1") = Array("Spieler", "Punkte", "Differenz")
Dim r As Long: r = 2
Dim key As Variant
For Each key In pts.Keys
wsRank.Cells(r, 1).Value = key
wsRank.Cells(r, 2).Value = pts(key)
wsRank.Cells(r, 3).Value = diff(key)
r = r + 1
Next key
' Sortierung: Punkte zuerst, dann Differenz
wsRank.Range("A1:C" & r - 1).Sort _
Key1:=wsRank.Range("B2"), Order1:=xlDescending, _
Key2:=wsRank.Range("C2"), Order2:=xlDescending, _
Header:=xlYes
MsgBox "Boule-Rangliste aktualisiert!", vbInformation
wsRank.Activate
End Sub
Option Explicit
Sub TurnierErstellen()
Dim wsStart As Worksheet
Dim wsPlan As Worksheet
Dim n As Long, plaetze As Long
Dim i As Long, j As Long
Dim players() As String
Dim rowOut As Long
Dim temp As String
Dim isOdd As Boolean
Set wsStart = ThisWorkbook.Sheets("Start")
n = wsStart.Range("B2").Value
plaetze = wsStart.Range("B3").Value
' Prüfen ob ungerade
If n Mod 2 > 0 Then
isOdd = True
n = n + 1 ' Dummy hinzufügen
End If
ReDim players(1 To n)
' Spieler einlesen
For i = 1 To n
If i = wsStart.Range("B2").Value Then
players(i) = wsStart.Cells(i + 5, 1).Value
Else
players(i) = "BYE"
End If
Next i
Set wsPlan = ThisWorkbook.Sheets("Spielplan")
wsPlan.Cells.Clear
wsPlan.Range("A1:G1") = Array("Runde", "Match", "Spieler 1", _
"Spieler 2", "Platz", "Punkte Team 1", "Punkte Team 2")
rowOut = 2
' Round Robin
For i = 1 To n - 1
For j = 1 To n / 2
Dim p1 As String, p2 As String
p1 = players(j)
p2 = players(n - j + 1)
' ?? BYE = kein Spiel
If p1 > "BYE" And p2 > "BYE" Then
wsPlan.Cells(rowOut, 1).Value = i
wsPlan.Cells(rowOut, 2).Value = j
wsPlan.Cells(rowOut, 3).Value = p1
wsPlan.Cells(rowOut, 4).Value = p2
wsPlan.Cells(rowOut, 5).Value = "Platz " & ((j - 1) Mod plaetze + 1)
'wsPlan.Cells(rowOut, 6).Value = Int((j - 1) / plaetze) + 1
rowOut = rowOut + 1
End If
Next j
' Rotation
temp = players(n)
For j = n To 3 Step -1
players(j) = players(j - 1)
Next j
players(2) = temp
Next i
MsgBox "Turnierplan erstellt (inkl. Freilose)!", vbInformation
wsPlan.Activate
End Sub
Sub RanglisteBoule()
Dim wsPlan As Worksheet, wsRank As Worksheet
Dim lastRow As Long, i As Long
Dim pts As Object, diff As Object
Set pts = CreateObject("Scripting.Dictionary")
Set diff = CreateObject("Scripting.Dictionary")
Set wsPlan = ThisWorkbook.Sheets("Spielplan")
lastRow = wsPlan.Cells(wsPlan.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
Dim p1 As String, p2 As String
Dim s1 As Variant, s2 As Variant
p1 = wsPlan.Cells(i, 3).Value
p2 = wsPlan.Cells(i, 4).Value
s1 = wsPlan.Cells(i, 6).Value
s2 = wsPlan.Cells(i, 7).Value
If p1 = "" Or p2 = "" Then GoTo skip
If Not pts.exists(p1) Then pts(p1) = 0
If Not pts.exists(p2) Then pts(p2) = 0
If Not diff.exists(p1) Then diff(p1) = 0
If Not diff.exists(p2) Then diff(p2) = 0
If IsNumeric(s1) And IsNumeric(s2) Then
' Punkte zählen
If s1 > s2 Then
pts(p1) = pts(p1) + 1
ElseIf s2 > s1 Then
pts(p2) = pts(p2) + 1
Else
' Unentschieden (falls erlaubt)
pts(p1) = pts(p1) + 0.5
pts(p2) = pts(p2) + 0.5
End If
' Differenz (Boule entscheidend!)
diff(p1) = diff(p1) + (s1 - s2)
diff(p2) = diff(p2) + (s2 - s1)
End If
skip:
Next i
' Rangliste erstellen
On Error Resume Next
Set wsRank = ThisWorkbook.Sheets("Rangliste")
On Error GoTo 0
If wsRank Is Nothing Then
Set wsRank = ThisWorkbook.Sheets.Add
wsRank.Name = "Rangliste"
End If
wsRank.Cells.Clear
wsRank.Range("A1:C1") = Array("Spieler", "Punkte", "Differenz")
Dim r As Long: r = 2
Dim key As Variant
For Each key In pts.Keys
wsRank.Cells(r, 1).Value = key
wsRank.Cells(r, 2).Value = pts(key)
wsRank.Cells(r, 3).Value = diff(key)
r = r + 1
Next key
' Sortierung: Punkte zuerst, dann Differenz
wsRank.Range("A1:C" & r - 1).Sort _
Key1:=wsRank.Range("B2"), Order1:=xlDescending, _
Key2:=wsRank.Range("C2"), Order2:=xlDescending, _
Header:=xlYes
MsgBox "Boule-Rangliste aktualisiert!", vbInformation
wsRank.Activate
End Sub
Else
' Unentschieden (falls erlaubt)
pts(p1) = pts(p1) + 0.5
pts(p2) = pts(p2) + 0.5