wedstrijden poule vraag

[beeksplace]

Geachte Excel specialisten,

Heb een poosje geleden een wedstrijdpoule gemaakt voor duel schutters en loop nog tegen een klein probleempje aan.
De wedstrijden worden keurig gemaakt en de uitslagen worden ook goed verwerkt. (met een random)

Als ik nu de wedstrijden genereer kan het zijn dat schutter 1 en 2 de eerste wedstrijd schieten op baan 1 en op baan 2 dan ook schutter 2 voorkomt in de lijst.

Hoe los ik dat op zodat er niet twee keer de zelfde schutter voorkomt.
Er zijn maar twee baanen om op te schieten, dus 4 schutter per keer.
Het aantal schutters kan variëren per wedstrijd.

Erik

 

[Elsendoorn2134]

Erik,

Als je toch al een keer een programma gemaakt hebt............

Veel Succes.

 

[beeksplace]

???

Elsendoorn2134,

leuk antwoord, maar als ik het wist dan had ik de vraag ook niet gesteld.
en eerlijk gezegd valt dit antwoord van een senior member wel een beetje tegen

erik

 

[Thankyou]

Wat elsendoorn2134 bedoeld: Graag een voorbeeldbestand bijvoegen waar het probleem in voorkomt.

 

[beeksplace]

Zo dan maar ff het bestand er bij stoppenBekijk bijlage duel wedstrijd v1.0_leeg.rar
als je bij de wedstrijden kijkt zie je dat in wedstrijd 3 twee keer nummer a12 staat en dat is wat ik wil voorkomen.

Erik

 

[Elsendoorn2134]

Erik,

Ik heb naar je programma gekeken en het zit goed in elkaar ik heb eigenlijk geen idee hoe ik dit zou moeten oplossen.
Per wedstrijd heb je twee banen beschikbaar waarop dus vier verschillende personen ingedeeld moeten worden.
Je wilt nu dat het programma hierin faciliteert. De enigste mogelijkheid die ik zie is dat je na het indelen de lijst doorloopt
en vaststelt of er dubbelingen voorkomen en deze dan handmatig aanpast.
Zou je dit handmatig willen doen dan zou je de wedstrijden in een array moeten opnemen, deze door moeten lopen
op dubbelingen, dubbelingen verplaatsen en opnieuw beginnen. Dit kan wel maar gaat me veel te veel tijd kosten.
Om je wat tegemoet te komen hier een versie van om je gegevens om te zetten in een array in plaats van een directory.

Sub Randomteams2()

  If MsgBox("U vervangt de huidige competitie!" & vbNewLine & "" & vbNewLine & "Weet u heel zeker dat u een nieuwe competitie wilt maken?", vbYesNo) = vbNo Then Exit Sub

  Dim Namen(), aWedstrijd(), i1 As Integer, i2 As Integer, LO As ListObject, arr(1 To 1, 1 To 3)
  Dim nTeller As Long
  
  Set LO = Range("Tabel2").ListObject                      'tabel voor uitvoer
  If LO.ListRows.Count Then LO.DataBodyRange.Delete        'leegmaken van die tabel

  Namen = Range("Tabel1")                                  'tabel met je namen
  ReDim aWedstrijd(Sheets("Teams").Range("N2") - 1, 2)
  
  For i1 = 1 To UBound(Namen) - 1                          'van de 1e tot voorlaatste naam
    For i2 = i1 + 1 To UBound(Namen)                       'van de volgende tot de laatste naam
      If Namen(i1, 3) = 1 And Namen(i2, 3) = 1 Then        'beide personen zijn aanwezig
        aWedstrijd(nTeller, 0) = Rnd
        aWedstrijd(nTeller, 1) = Namen(i1, 2)
        aWedstrijd(nTeller, 2) = Namen(i2, 2)  '3 elementen : een willekeurig getal tss 0 en 1, 1e naam en 2e naam
        nTeller = nTeller + 1
      End If
    Next
  Next
  
  aWedstrijd = BubbleSort(aWedstrijd)                       'Sorteren op basis van random waarde
  
  If UBound(aWedstrijd) Then
    LO.ListRows.Add.Range.Resize(nTeller - 1, UBound(arr, 2)).Value = Application.Index(aWedstrijd, 0, 0) 'dictionary naar tabel schrijven
    With LO.DataBodyRange
      '.Sort .Range("A1"), Header:=xlYes                    'sorteren op dat willekeurig getal
      .Columns(1).Value = 1
    End With
  End If
End Sub

Voor het sorteren van de array gebruik ik een aangepaste versie van je bubblesort.

Private Function BubbleSort(MyArray)

  Dim First    As Integer
  Dim Last     As Integer
  Dim i        As Integer
  Dim j        As Integer
  Dim aTemp(2)   As Variant

  First = LBound(MyArray)
  Last = UBound(MyArray)
  For i = First To Last - 1
    For j = i + 1 To Last
      If MyArray(i, 0) < MyArray(j, 0) Then
        aTemp(0) = MyArray(j, 0)
        aTemp(1) = MyArray(j, 1)
        aTemp(2) = MyArray(j, 2)
        MyArray(j, 0) = MyArray(i, 0)
        MyArray(j, 1) = MyArray(i, 1)
        MyArray(j, 2) = MyArray(i, 2)
        MyArray(i, 0) = aTemp(0)
        MyArray(i, 1) = aTemp(1)
        MyArray(i, 2) = aTemp(2)
      End If
    Next j
  Next i

  BubbleSort = MyArray

End Function

Veel Succes.

 

[beeksplace]

Elsendoorn2134

Dank voor je bericht.
Nu doen we het op de volgende manier en slaan gewoon die wedstrijd over en nemen de volgende in de reeks.
Dan moeten we het maar zo blijven doen als het niet anders kan of iemand anders komt nog met een oplossing.
Zal zeker nog even goed naar je code kijken.

erik