Dartcompetitie maken

Esperantia · 30 okt 2006

Hallo,

Ben niet zo goed met excel.Mijn vraag is dan ook: Kan iemand mij een schema bezorgen voor een hele dartcompetitie van minimaal 14 personen.
Het programma wil ik best bekostigen.Groet,
Esperantia

Joske2000 · 30 okt 2006

Hi Esperantia,

Welkom op het forum !

Hierbij een schema voor 14 personen en/of teams.
Hoogstwaarschijnlijk is dit niet voldoende.
Graag wat meer info.
Wat moet er kunnen, wat moet het programma doen.

Greetz,

Joske

Esperantia · 30 okt 2006

Dartcompetitie

Hoi,

Alvast bedankt. Ik wil alleen dat voor die 14 personen een wedstrijdschema eruit rolt.Daarmaa bedoel ik dat de 14 mensen dus 26 wedstrijden spelen.Dus 2 maal tegen iedereen.
Alvast bedankt.
Groetjes,
Esperantia:shocked: :thumb:

Demeter · 30 okt 2006

Ook leuk om naar te kijken:

http://www.helpmij.nl/forum/showthread.php?t=263308

Met dank aan Wigi.

Groet,
Ferenc

Joske2000 · 30 okt 2006

Het bestandje van Wigi is inderdaad behoorlijk knap in mekaar gestopt.
Maar dat zijn we gewend van Wigi hé. :thumb:

Als basis hierbij een bestandje met een schema voor 14 spelers. Iedereen speelt 2 maal tegen iedereen.
Je vult gewoon de namen in de gele cellen, en dan kan je het gewoon afdrukken.
Ik weet niet of het voldoende is, anders hoor ik het wel !

Joske.

Esperantia · 30 okt 2006

Dartcompetitie

Hoi,

Allereerst bedankt dat iedereen wil helpen. Super !!!
En ff reageren of ik het zo goed vind ???

Het is super, maar ik wil graag dat iedereen in week 1, twee wedstrijden speelt. En in week 2 ook enzv totdat we in week 13 de laatste 2 wedstrijden spelen, want iedereen moet 2 maal tegen elkaar en 2wedstrijden per week , wil dus zeggen, na 13 weken is de competitie klaar.
Alvast bedankt,
Esperantia:thumb:

Joske2000 · 30 okt 2006

Hi Esperantia,

Zoiets als in bijlage ?

Joske

Wigi · 30 okt 2006

Joske

zie eens naar bijgevoegd bestand. Volgens mij zitten er fouten in je voorstel.

Joske2000 · 30 okt 2006

Knap gezien Wigi,

Hierbij de correcte versie .

Thx :thumb: :thumb:

Greetz,

Joske

Esperantia · 30 okt 2006

Dartcompetitie

Hallo,

Super hartelijk bedankt, echt te gek.
gr,
Esperantia

:thumb:

Wigi · 30 okt 2006

Joske2000 zei:
Knap gezien Wigi,

Hierbij de correcte versie .

Thx :thumb: :thumb:

Greetz,

Joske

Joske

ik ben nu wel benieuwd hoe je dit gedaan hebt. Ik zie geen VBA code...

Joske2000 · 31 okt 2006

Wigi,

knippen en plakken vanuit een bestaande rooster voor 14 teams.

Joske

Wigi · 31 okt 2006

Joske2000 zei:
Wigi,

knippen en plakken vanuit een bestaande rooster voor 14 teams.

Joske

Ah OK, ik dacht dat je manueel dat in mekaar gestoken had.

Ben trouwens zelf nog bezig met wat VBA code, maar het wilt nog niet zo goed lukken

:evil: Als het lukt horen jullie er nog van, anders gaat het de prullenbak in.

Wigi

Wigi · 31 okt 2006

Wigi zei:
Ben trouwens zelf nog bezig met wat VBA code, maar het wilt nog niet zo goed lukken :evil: Als het lukt horen jullie er nog van, anders gaat het de prullenbak in.

Heel nederig moet ik toegeven dat mijn pogingen gestrand zijn... Maar er is wel code om dit soort competities op te zetten. Voer maar eens deze code uit:

Code:

Sub initializeSystem(ByRef TeamMap() As Byte, ByRef AvailTeams() As Byte)
    Dim i As Integer, j As Integer

    For i = 1 To UBound(TeamMap, 1)
        For j = i + 1 To UBound(TeamMap, 1)
            TeamMap(i, j) = 1
        Next j
    Next i
    
    For i = 1 To UBound(AvailTeams)
        AvailTeams(i) = 1
    Next i

End Sub

Function FirstAvailCompetitor(TeamMap() As Byte, ByVal CurrTeam As Integer, AvailTeams() As Byte, _
    ByVal StartAfter As Integer) As Integer
    
    Dim i As Integer
    
    If StartAfter = 0 Then StartAfter = CurrTeam
    
    For i = StartAfter + 1 To UBound(TeamMap, 2)
        If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
            FirstAvailCompetitor = i
            Exit Function
        End If
    Next i
End Function

Function FindRandomCompetitor(ByRef TeamMap() As Byte, CurrTeam As Integer, AvailTeams() As Byte) As Integer

    Dim i As Integer, StartAt As Integer

    StartAt = Fix(Rnd() * (UBound(TeamMap, 1) - CurrTeam)) + CurrTeam + 1
    i = StartAt
    
    Do
        If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
            FindRandomCompetitor = i
            Exit Function
        End If
        
        If i = UBound(TeamMap, 2) Then
            i = CurrTeam + 1
        Else: i = i + 1
        End If
    Loop Until i = StartAt
End Function

Function FindCompetitor(ByRef TeamMap() As Byte, CurrTeam As Integer, AvailTeams() As Byte, StartAfter As Integer) As Integer
    
    Dim i As Integer, StartAt As Integer
    If StartAfter = 0 Then
        FindCompetitor = FindRandomCompetitor(TeamMap, CurrTeam, AvailTeams)
    Else
        FindCompetitor = FirstAvailCompetitor(TeamMap, CurrTeam, AvailTeams)
    End If
End Function

Function FirstAvailTeam(ByRef AvailTeams() As Byte) As Integer

    Dim i As Integer
    
    For i = 1 To UBound(AvailTeams)
        If AvailTeams(i) = 1 Then
            FirstAvailTeam = i
            Exit Function
        End If
    Next i
End Function

Function schedAPair(ByVal nbrTeams As Integer, ByRef TeamMap() As Byte, AvailTeams() As Byte, RecursionDepth As Integer, _
    ByRef RsltMap() As Integer) As Boolean

    Dim T1 As Integer, T2 As Integer, Done As Boolean, Success As Boolean, FailureCount As Integer
    T1 = FirstAvailTeam(AvailTeams)
    
    If T1 = 0 Then  'all teams assigned
        schedAPair = True
        Exit Function
    End If
    
    T2 = FindRandomCompetitor(TeamMap, T1, AvailTeams)
    
    Do
        If T2 = 0 Then 'infeasible solution
            Done = True
        Else
            AvailTeams(T1) = 0: AvailTeams(T2) = 0
            RsltMap(RecursionDepth, 1) = T1
            RsltMap(RecursionDepth, 2) = T2
            Success = schedAPair(nbrTeams, TeamMap, AvailTeams, RecursionDepth + 1, RsltMap)
            
            If Not Success Then    'Infeasible solution downstream
                FailureCount = FailureCount + 1
                AvailTeams(T1) = 1: AvailTeams(T2) = 1
                RsltMap(RecursionDepth, 1) = 0
                RsltMap(RecursionDepth, 2) = 0
                T2 = FirstAvailCompetitor(TeamMap, T1, _
                    AvailTeams, IIf(FailureCount = 1, 0, T2))
                End If
            Done = Success
            End If
        Loop Until Done
    schedAPair = Success
    End Function

Sub printRslt(RsltMap() As Integer)
    Dim dest As Range, i As Integer
    Set dest = Cells(Cells.Rows.Count, Selection.Column).End(xlUp).Offset(1, 0)

    For i = 1 To UBound(RsltMap, 1)
        dest.Offset(0, i - 1).Value = RsltMap(i, 1) & ", " & RsltMap(i, 2)
    Next i
End Sub

Sub updateSystem(ByRef TeamMap() As Byte, ByRef RsltMap() As Integer, ByRef AvailTeams() As Byte)

    Dim i As Integer
    For i = 1 To UBound(RsltMap, 1)
        TeamMap(RsltMap(i, 1), RsltMap(i, 2)) = 0
        RsltMap(i, 1) = 0: RsltMap(i, 2) = 0
    Next i
    
    For i = 1 To UBound(AvailTeams)
        AvailTeams(i) = 1
    Next i
End Sub

Sub ScheduleManager()
    Dim nbrTeams As Integer, SchedRslt As Boolean
    
    nbrTeams = Application.InputBox("Enter number of teams (must be an even number)", , 18, , , , , 1)
    
    If nbrTeams Mod 2 = 1 Then
        MsgBox "Please enter an even number (2, 4, 6, etc.)"
        Exit Sub
    End If
    
    ReDim TeamMap(1 To nbrTeams, 1 To nbrTeams) As Byte, RsltMap(1 To nbrTeams / 2, 1 To 2) As Integer, AvailTeams(1 To nbrTeams) As Byte
        'actually need only upper triangle matrix
        '(above the main diagonal)
    initializeSystem TeamMap, AvailTeams
        'Establishes all valid combinations
    
    Do
        SchedRslt = schedAPair(nbrTeams, TeamMap, AvailTeams, 1, RsltMap)
        If SchedRslt Then
            printRslt RsltMap()
            updateSystem TeamMap, RsltMap, AvailTeams
            End If
        Loop While SchedRslt
    End Sub

Alle krediet aan Excel MVP Tushar Mehta. Code werd hier gepost.

Wigi

Wigi · 1 nov 2006

Om op de vraag over het genereren van een competitie (als die nog niet afdoende beantwoord is): ben non wat aan het spelen gegaan.

Voer onderstaande macro eens uit op een nieuw werkblad.

Het eerste stuk is van mijn hand, de rest van Tushar Mehta (vanaf Sub initializeSystem)

Code:

Sub SchemaCompetitie()
Dim AantPloegen As Integer, AantMatchenPerWeekPerPloeg As Integer, AantKerenTegenMekaar As Integer
Dim AantMatchen As Integer, AantMatchenPerWeek As Integer, weeknr As Integer
Dim TeamSpeler As String, r As Integer, i As Integer, c As Range

Application.ScreenUpdating = False

MsgBox "Er worden eerst wat gegevens opgevraagd." & vbCr & vbCr & "Vul die correct in en dan wordt de kalender gegenereerd."

TeamSpeler = Application.InputBox("Gaat het om teams of spelers?" & vbCr & vbCr & "Typ het woord team of speler in." _
    , "Vraag 1 van 4", "team", , , , 2)
TeamSpeler = LCase(TeamSpeler)

AantPloegen = Application.InputBox("Wat is het aantal " & TeamSpeler & "s? (Moet een even aantal zijn)", _
    "Vraag 2 van 4", 14, , , , 1)
AantMatchenPerWeekPerPloeg = Application.InputBox("Hoeveel matchen speelt elk" & IIf(TeamSpeler = "team", " ", "e ") & _
    TeamSpeler & " per week?", "Vraag 3 van 4", 2, , , , 1)
AantKerenTegenMekaar = Application.InputBox("Hoeveel keer spelen de " & TeamSpeler & "s tegen mekaar?", _
    "Vraag 4 van 4", 2, , , , 1)

AantMatchen = AantPloegen * (AantPloegen - 1) * AantKerenTegenMekaar / 2
AantMatchenPerWeek = AantMatchenPerWeekPerPloeg * AantPloegen / 2

With Range("A1")
    .CurrentRegion.ClearContents
    .Offset(, 0) = "Match"
    .Offset(, 1) = "Week"
    .Offset(, 2) = "Match per week"
    .Offset(, 3) = "Thuis"
    .Offset(, 4) = "Uit"
    .Resize(, 5).Font.Bold = True
    
    For r = 1 To AantMatchen
        weeknr = Int((r - 0.1) / (AantMatchenPerWeek / 2)) + 1
        .Offset(r, 0) = r
        .Offset(r, 1) = weeknr
        .Offset(r, 2) = IIf(weeknr / 2 - Int(weeknr / 2) = 0.5, 1, 2)
    Next

    ScheduleManager (AantPloegen)
    
.Offset(1, 3).Resize(AantMatchen / 2).Copy .Offset(AantMatchen / 2 + 1, 4)
.Offset(1, 4).Resize(AantMatchen / 2).Copy .Offset(AantMatchen / 2 + 1, 3)

    For Each c In .Offset(1, 3).Resize(AantMatchen, 2)
        c = TeamSpeler & " " & c
    Next
    
    .Resize(, 5).EntireColumn.AutoFit
    .Offset(, 5).Resize(, 4).EntireColumn.ClearContents
    .Select

End With

Application.ScreenUpdating = True
End Sub

Sub initializeSystem(ByRef TeamMap() As Byte, ByRef AvailTeams() As Byte)
    Dim i As Integer, j As Integer

    For i = 1 To UBound(TeamMap, 1)
        For j = i + 1 To UBound(TeamMap, 1)
            TeamMap(i, j) = 1
        Next j
    Next i
    
    For i = 1 To UBound(AvailTeams)
        AvailTeams(i) = 1
    Next i

End Sub

Function FirstAvailCompetitor(TeamMap() As Byte, ByVal CurrTeam As Integer, AvailTeams() As Byte, _
    ByVal StartAfter As Integer) As Integer
    
    Dim i As Integer
    
    If StartAfter = 0 Then StartAfter = CurrTeam
    
    For i = StartAfter + 1 To UBound(TeamMap, 2)
        If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
            FirstAvailCompetitor = i
            Exit Function
        End If
    Next i
End Function

Function FindRandomCompetitor(ByRef TeamMap() As Byte, CurrTeam As Integer, AvailTeams() As Byte) As Integer

    Dim i As Integer, StartAt As Integer

    StartAt = Fix(Rnd() * (UBound(TeamMap, 1) - CurrTeam)) + CurrTeam + 1
    i = StartAt
    
    Do
        If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
            FindRandomCompetitor = i
            Exit Function
        End If
        
        If i = UBound(TeamMap, 2) Then
            i = CurrTeam + 1
        Else: i = i + 1
        End If
    Loop Until i = StartAt
End Function

Function FindCompetitor(ByRef TeamMap() As Byte, CurrTeam As Integer, AvailTeams() As Byte, StartAfter As Integer) As Integer
    
    Dim i As Integer, StartAt As Integer
    If StartAfter = 0 Then
        FindCompetitor = FindRandomCompetitor(TeamMap, CurrTeam, AvailTeams)
    Else
        FindCompetitor = FirstAvailCompetitor(TeamMap, CurrTeam, AvailTeams)
    End If
End Function

Function FirstAvailTeam(ByRef AvailTeams() As Byte) As Integer

    Dim i As Integer
    
    For i = 1 To UBound(AvailTeams)
        If AvailTeams(i) = 1 Then
            FirstAvailTeam = i
            Exit Function
        End If
    Next i
End Function

Function schedAPair(ByVal nbrTeams As Integer, ByRef TeamMap() As Byte, AvailTeams() As Byte, RecursionDepth As Integer, _
    ByRef RsltMap() As Integer) As Boolean

    Dim T1 As Integer, T2 As Integer, Done As Boolean, Success As Boolean, FailureCount As Integer
    T1 = FirstAvailTeam(AvailTeams)
    
    If T1 = 0 Then  'all teams assigned
        schedAPair = True
        Exit Function
    End If
    
    T2 = FindRandomCompetitor(TeamMap, T1, AvailTeams)
    
    Do
        If T2 = 0 Then 'infeasible solution
            Done = True
        Else
            AvailTeams(T1) = 0: AvailTeams(T2) = 0
            RsltMap(RecursionDepth, 1) = T1
            RsltMap(RecursionDepth, 2) = T2
            Success = schedAPair(nbrTeams, TeamMap, AvailTeams, RecursionDepth + 1, RsltMap)
            
            If Not Success Then    'Infeasible solution downstream
                FailureCount = FailureCount + 1
                AvailTeams(T1) = 1: AvailTeams(T2) = 1
                RsltMap(RecursionDepth, 1) = 0
                RsltMap(RecursionDepth, 2) = 0
                T2 = FirstAvailCompetitor(TeamMap, T1, _
                    AvailTeams, IIf(FailureCount = 1, 0, T2))
                End If
            Done = Success
            End If
        Loop Until Done
    schedAPair = Success
    End Function

Sub printRslt(RsltMap() As Integer)
    Dim dest As Range, i As Integer
    Set dest = Cells(Cells.Rows.Count, 4).End(xlUp).Offset(1)

    For i = 1 To UBound(RsltMap, 1)
        dest.Offset(i - 1, 0).Value = RsltMap(i, 1)
        dest.Offset(i - 1, 1).Value = RsltMap(i, 2)
    Next i
End Sub

Sub updateSystem(ByRef TeamMap() As Byte, ByRef RsltMap() As Integer, ByRef AvailTeams() As Byte)

    Dim i As Integer
    For i = 1 To UBound(RsltMap, 1)
        TeamMap(RsltMap(i, 1), RsltMap(i, 2)) = 0
        RsltMap(i, 1) = 0: RsltMap(i, 2) = 0
    Next i
    
    For i = 1 To UBound(AvailTeams)
        AvailTeams(i) = 1
    Next i
End Sub

Sub ScheduleManager(ploegen As Integer)
    Dim nbrTeams As Integer, SchedRslt As Boolean
    
    nbrTeams = ploegen
    
    If nbrTeams Mod 2 = 1 Then
        MsgBox "Please enter an even number (2, 4, 6, etc.)"
        Exit Sub
    End If
    
    ReDim TeamMap(1 To nbrTeams, 1 To nbrTeams) As Byte, RsltMap(1 To nbrTeams / 2, 1 To 2) As Integer, AvailTeams(1 To nbrTeams) As Byte
        'actually need only upper triangle matrix
        '(above the main diagonal)
    initializeSystem TeamMap, AvailTeams
        'Establishes all valid combinations
    
    Do
        SchedRslt = schedAPair(nbrTeams, TeamMap, AvailTeams, 1, RsltMap)
        If SchedRslt Then
            printRslt RsltMap()
            updateSystem TeamMap, RsltMap, AvailTeams
        End If
    Loop While SchedRslt
End Sub

Wigi

willemsebel · 3 aug 2008

Wigi,

Deze is helemaal super, ik begrijp nu wel dat een competitie van 13 teams niet te maken is.

Nog één vraag: is het mogelijk om de teams om en om uit en thuis te laten spelen?

Willem

Wigi · 3 aug 2008

willemsebel zei:
Deze is helemaal super, ik begrijp nu wel dat een competitie van 13 teams niet te maken is.

Waarom niet? Dat is toch gewoon maar een competitie met 14 waarbij elke ploeg 2 keer vrij is? (dus als je wil, ploeg nr 14 heet VRIJ en je gebruikt hetzelfde schema).

willemsebel · 3 aug 2008

Ja die had ik al begrepen

, ik bedoelde specifiek voor 13 teams..... :thumb:

willemsebel · 3 aug 2008

Is het mogelijk voor je om hem aan te passen naar 12 teams?

Willem

Dartcompetitie maken

Nieuwe gebruiker

Terugkerende gebruiker

Bijlagen

Nieuwe gebruiker

Verenigingslid

Terugkerende gebruiker

Bijlagen

Nieuwe gebruiker

Terugkerende gebruiker

Bijlagen

Inventaris

Bijlagen

Terugkerende gebruiker

Bijlagen

Nieuwe gebruiker

Inventaris

Terugkerende gebruiker

Inventaris

Inventaris

Inventaris

Gebruiker

Inventaris

Gebruiker

Gebruiker

Wij waarderen jouw privacy