Random auto indeling vereenvoudigen

Peter B · 26 jun 2017

Ik ben aan het stoeien met een random auto indeling. Dat is op zich gelukt, maar gevoelsmatig moet het (veel) eenvoudiger kunnen, hoewel ik wel een aantal eisen heb die het niet gemakkelijker maken:
- In kolom B staan de chauffeurs. Deze moeten bij de indeling altijd bovenaan staan
- Als een auto niet vol zit (3 inzittenden) moet een "-" worden getoond
- Het is niet de bedoeling dat altijd de laatste auto(s) het kleinste aantal inzittenden hebben

Als dan ook nog kan worden voldaan aan de eis dat in iedere auto minimaal 2 personen zitten dan zou het helemaal top zijn (dat zit er nu nog niet in).

Bekijk bijlage Husselen.xlsm

Timshel · 26 jun 2017

Eenvoudiger? Nee, niet echt.
Wel een andere benadering:

Code:

Sub tsh()
    Dim i As Long
    Dim Bp, Bc, Bu
    
    Bc = Application.Transpose(Sheets(1).Cells(2, 2).Resize(Cells(Rows.Count, 2).End(xlUp).Row - 1))
    Bp = Application.Transpose(Sheets(1).Cells(1, 1).Resize(Application.RoundUp((Cells(Rows.Count, 1).End(xlUp).Row - 1) / 3, 0) * 3 + 1))
    With CreateObject("System.Collections.Arraylist")
        For i = 2 To UBound(Bp)
            If Bp(i) = "" Then Bp(i) = "~~~~" & i
            .Add Bp(i) & "|" & IIf(IsError(Application.Match(Bp(i), Bc, 0)), "Passagier", "Chauffeur")
        Next
        Bp = .ToArray
    End With
    
    ReDim Bu(UBound(Bp))
    Bc = Filter(Bp, "Chauffeur", True)
    Bp = Filter(Bp, "Passagier", True)
    For i = 0 To UBound(Bu)
        If i Mod 3 = 0 Then
            Bu(i) = Split(Bc(Int(Rnd() * (UBound(Bc) + 1))), "|")(0)
            Bc = Filter(Bc, Bu(i) & "|", False)
        Else
            Bu(i) = Split(Bp(Int(Rnd() * (UBound(Bp) + 1))), "|")(0)
            Bp = Filter(Bp, Bu(i) & "|", False)
        End If
    Next
    Sheets(1).Range("E6").Resize(UBound(Bu) + 1) = Application.Transpose(Bu)
End Sub

snb · 26 jun 2017

Code:

Sub M_snb()
  Sheet1.Cells(1).CurrentRegion.Columns(1).Offset(1).SpecialCells(2).Offset(, 10).Name = "snb"
  [snb] = "=rand()"
  sn = [transpose(rank(snb,snb))]
  [snb].ClearContents
  
  sp = Sheet1.Cells(1).CurrentRegion.Columns(2).SpecialCells(2)
  sq = Sheet1.Cells(1).CurrentRegion.Columns(1).SpecialCells(2)
  
  With CreateObject("scripting.dictionary")
     For j = 2 To UBound(sp)
         .Item(.Count) = sp(j, 1)
     Next
     
     For j = 1 To UBound(sn)
        .Item(j Mod .Count) = .Item(j Mod .Count) & "|" & sq(sn(j) + 1, 1)
     Next
     
     For j = 0 To .Count - 1
       st = Split(.items()(j), "|")
       Cells(29 + j, 4).Resize(, UBound(st) + 1) = st
     Next
  End With
End Sub

Peter B · 26 jun 2017

@Timshel, ik heb je andere benadering bestudeerd. Ziet er goed uit. Ik zou nog wat moeten tweaken om de totaal aantallen goed te krijgen. Inderdaad niet echt eenvoudiger. Het ziet er wel wat logischer uit.

Peter B · 26 jun 2017

@snb, ik begin net arrays onder de knie te krijgen (denk ik) kom jij weer met dictionary's

Weer iets om mij in te verdiepen dus. Ga ik ook zeker doen.

Voor nu ziet het er eenvoudig uit maar krijg ik niet helemaal het resultaat wat ik wil hebben:
1. De chauffeurs worden nogmaals ingedeeld (in kolom D staan de chauffeurs, maar deze worden allemaal herhaald in de kolommen E-H
2. Het lijkt alsof er meer personen per auto worden toegestaan. Echter blijken in kolom H dubbelingen te staan

Dit is de output die ik heb gekregen (eerste maal draaien):

Code:

[b]D	E	F	G	H[/b]
--	--	--	--	--	
a	~~~~	b	c	
c	a	h	f	g
k	n	l	g	l
l	m	e	j	d
n	i	d	k

snb · 26 jun 2017

Mijn auto's staan per regel.

Chauffeurs zijn uniek in kolom B.

Als jij vindt dat chauffeurs ook in kolom A staan heb je een probleem.

Timshel · 26 jun 2017

Ik vermoed dat meerdere deelnemers uit kolom A beschikken over een rijbewijs en dat er gerouleerd wordt wie deze keer chauffeert.
Kolom A "inzittenden" moet dus nog gesplitst worden in chauffeurs en passagiers. Niets dat een beetje extra code niet kan fiksen.

Peter B · 27 jun 2017

Grappig om te stellen dat ik dan een probleem heb ... Ik heb spelers, en die spelers kunnen allemaal rijden. Het rijden gaat op basis van een roulatiesysteem.

Ik houd bij wie er spelen (niet iedereen is iedere keer aanwezig) en ik houd bij wie er moeten rijden. Dit zijn de 2 overzichten die ik heb en die ik dus als basis wil laten dienen voor het husselen.

snb · 27 jun 2017

Als je dan toch bezig bent is het verstandig de groep van inzittenden niet te vervuilen met chauffeurs.
Dan loopt de macro vlekkelings en ben jij tevreden over het resultaat.
Want als iedereen een rijbewijs heeft kunnen gewoon alle deelnemers random over de auto's verdeeld worden. De eerst toegewezene is dan de chauffeur.
Maximale roulatie.
Maar waarom een werkbladformule als dat eenvoudiger in VBA kan ?

Code:

Sub M_snb()
  sn = Cells(1).CurrentRegion
  Cells(1, 3).CurrentRegion.Offset(1).ClearContents
  y = (UBound(sn) - 1) \ 4 - ((UBound(sn) - 1) Mod 4 <> 0)
  
  Cells(1).CurrentRegion.Columns(1).Offset(1).SpecialCells(2).Offset(, 10).Name = "snb"
  [snb] = "=rand()"
  sq = [transpose(rank(snb,snb))]
  [snb].ClearContents
  
  With CreateObject("scripting.dictionary")
     For j = 2 To UBound(sn)
        .Item(j Mod y) = IIf(.Item(j Mod y) = "", "Auto " & .Count, .Item(j Mod y)) & "|" & sn(sq(j - 1) + 1, 1)
     Next
     
     For j = 0 To .Count - 1
       st = Split(.items()(j), "|")
       Cells(2 + j, 3).Resize(, UBound(st) + 1) = st
     Next
  End With
End Sub

Peter B · 27 jun 2017

Oi. Dat ziet er uit als een galante oplossing. Ik moet hem eens goed gaan bestuderen om 'm echt te gaan begrijpen.

Er zit nog één probleempje in, en dat is de aanname dat iedereen iedere week kan rijden. Het probleem is dat niet iedereen altijd over een auto kan beschikken (een chauffeur rijdt alleen in zijn/ haar eigen auto). Ik krijg van te voren door als spelers een keer niet kunnen rijden. Dat is de reden dat ik de chauffeurs apart indeel.

snb · 27 jun 2017

Als je het met arrays wil aanpakken:

Code:

Sub M_snb()
  sn = Cells(1).CurrentRegion
  Cells(1, 3).CurrentRegion.Offset(1).ClearContents
   
  Cells(1).CurrentRegion.Columns(1).Offset(1).SpecialCells(2).Offset(, 10).Name = "snb"
  [snb] = "=rand()"
  sq = [transpose(rank(snb,snb))]
  [snb].ClearContents
  
  ReDim sp((UBound(sn) - 1) \ 4 - ((UBound(sn) - 1) Mod 4 <> 0), 4)
  For j = 0 To UBound(sn) - 2
    If j Mod UBound(sp, 2) = 0 Then sp(j \ UBound(sp, 2), j Mod UBound(sp, 2)) = "Auto " & j \ UBound(sp, 2) + 1
    sp(j \ UBound(sp, 2), j Mod UBound(sp, 2) + 1) = sn(sq(j + 1) + 1, 1)
  Next
  
  Cells(2, 3).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub

jkpieterse · 27 jun 2017

Niet per se eenvoudiger, maar een andere aanpak die ook op een Mac zou werken:

Code:

Sub HusselenJKP()
    Dim colRijders As Collection
    Dim colSpelers As Collection
    Dim lAuto As Long
    Dim lAutoCt As Long
    Dim lRijderCt As Long
    Dim lSpeler As Long
    Dim lSpelerCt As Long
    Dim vSpelers As Variant
    Dim vAutos As Variant
    Dim vRijders As Variant
    'lees spelers en rijders
    vSpelers = Range(Range("A2"), Range("A2").End(xlDown)).Value2
    vRijders = Range(Range("B2"), Range("B2").End(xlDown)).Value2
    vAutos = vSpelers

    'maak er collecties van, makkelijker spelers verwijderen
    Set colRijders = New Collection
    For lRijderCt = 1 To UBound(vRijders, 1)
        colRijders.Add vRijders(lRijderCt, 1), vRijders(lRijderCt, 1)
    Next
    Set colSpelers = New Collection
    For lSpelerCt = 1 To UBound(vSpelers, 1)
        If Not isin(colRijders, CStr(vSpelers(lSpelerCt, 1))) Then
            colSpelers.Add vSpelers(lSpelerCt, 1), vSpelers(lSpelerCt, 1)
        End If
    Next
    ReDim vAutos(1 To colSpelers.Count, 1 To 2)
    For lRijderCt = colRijders.Count To 1 Step -1
        lAuto = Round(Rnd() * colRijders.Count + 0.501, 0)
        For lSpelerCt = 1 To 2
            lAutoCt = lAutoCt + 1
            lSpeler = Round(Rnd() * colSpelers.Count + 0.501, 0)
            If lSpeler <> 0 Then
                vAutos(lAutoCt, 1) = colRijders(lAuto)
                vAutos(lAutoCt, 2) = colSpelers(lSpeler)
                colSpelers.Remove lSpeler
            End If
        Next
        colRijders.Remove lAuto
    Next
    Range("G1").Resize(UBound(vAutos, 1), UBound(vAutos, 2)).Value = vAutos
End Sub

Public Function isin(colCollection As Collection, sKey As String)
    Dim v As Variant
    On Error Resume Next
    For Each v In colCollection
        If v = sKey Then
            isin = True
            Exit Function
        End If
    Next
End Function

Peter B · 29 jun 2017

@jkp: Ook jij bedankt voor het aandragen van een oplossing. Collections? Nog meer om mij in te verdiepen ...

Ik loop wel tegen een probleempje aan als meer mensen afwezig zijn en ik twee keer dezelfde waarde heb staan ("-" of "~~~~") omdat deze waarde dan dubbel wordt toegekend.

Peter B · 29 jun 2017

@snb: In beide oplossingen mis ik de optie om rijders uit te filteren die geen auto tot zijn beschikking hebben. Misschien kun je meedenken over de vorm waarin dit wordt gegoten? Ik plan nu de rijders zelf handmatig in o.b.v. deze gegevens. Het zou denk ik mooier zijn als de "Nee" bij een datum/ persoon wordt gebruikt om deze persoon uit te sluiten van rijden.

Heb jij hier een slimme oplossing voor?

snb · 29 jun 2017

in kolom A: de spelers
in kolom B: de chauffeurs
kolom C: leeg

Code:

Sub M_snb()
  sn = Application.Transpose(Cells(1).CurrentRegion.Columns(1))
  st = Cells(1).CurrentRegion
  
  Cells(1, 4).CurrentRegion.Offset(1).ClearContents
  
  Cells(1, 10).Resize(UBound(sn) - Cells(1).CurrentRegion.Columns(2).SpecialCells(2).Count).Name = "snb"
  [snb] = "=rand()"
  sp = [transpose(rank(snb,snb))]
  [snb].ClearContents
  
  ReDim sq(Application.Ceiling(UBound(sn), 4) \ 4 - 1, 4)
  
  For j = 0 To UBound(sq)
    sq(j, 0) = "Auto " & j + 1
    sq(j, 1) = st(j + 2, 2)
    sn = Filter(sn, sq(j, 1), 0)
  Next
  
  For j = 0 To UBound(sp) - 1
     sq(j \ (UBound(sq, 2) - 1), j Mod (UBound(sq, 2) - 1) + 2) = sn(sp(j + 1) - 1)
  Next
  
  Cells(2, 4).Resize(UBound(sq) + 1, UBound(sq, 2) + 1) = sq
End Sub

En vervolgens heb je natuurlijk ook nog een tabel van mensen die zeker niet met een bepaalde chauffeur in de auto willen zitten....

Peter B · 29 jun 2017

snb zei:
En vervolgens heb je natuurlijk ook nog een tabel van mensen die zeker niet met een bepaalde chauffeur in de auto willen zitten....

Nee hoor

Dat is juist de reden dat ik een random auto-indeling wil hebben. Ik zal later vandaag je code bestuderen. Dank je wel alvast!

Peter B · 3 jul 2017

@snb
Ik ben nu al een tijdje aan het puzzelen met je oplossing. Ik zie de volgende problemen:
1. Ik miste de 2 laatste namen. heb de volgende regel aangepast (starten bij 2 heeft te maken met het uitsluiten van de kopregel; zie punt 4) - aangepast:

Code:

.Cells(2, 10).Resize(UBound(sn) - .Cells(1).CurrentRegion.Columns(2).SpecialCells(2).Count + 1).Name = "snb"

2. In de laatste auto zitten altijd de minste mensen. Dat is vervelend als je standaard achter in het rijtje staat. Is op te lossen door de chauffeurs steeds handmatig anders in te vullen, maar is niet wenselijk. Is dit op te lossen?
3. De autobezetting moet beter verdeeld zijn. Dus in jouw opzet bij 13 spelers niet 4,4,4,1 maar 4,3,3,3 (en dan dus bij voorkeur willekeurig zodat ik hier geen rekening mee hoef te houden bij het invullen van de chauffeurs). Met in het achterhoofd het maximum van 3 inzittenden heb je het dan over 3,3,3,3,1 waar ik 3,3,3,2,2 zou willen
4. De kopregel "Spelers" wordt ook ingedeeld. Heb ik ondervangen door op een andere manier selecteren (cells(2,1) t/m laatst gevulde cel) - aangepast
5. Ik zie liever een kolom met alle spelers onder elkaar i.p.v. een matrix. Dit i.v.m. de uiteindelijke opmaak van de e-mail
6. Ik heb de autoindeling gewijzigd naar max. 3 inzittenden per auto (incl. chauffeur). Zo kunnen ook altijd fans meerijden (ik kan ook beginnen over de Toyota IQ; gelukkig heeft niemand een Smart) - aangepast

Volledige code:

Code:

Sub M_snb_Peter()
With Sheet1
  sn = Application.Transpose(.Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "A")))
  st = .Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "B"))
  
  .Cells(1, 4).CurrentRegion.Offset(1).ClearContents
  
  .Cells(2, 10).Resize(UBound(sn) - .Cells(1).CurrentRegion.Columns(2).SpecialCells(2).Count + 1).Name = "snb"
  [snb] = "=rand()"
  sp = [transpose(rank(snb,snb))]
  [snb].ClearContents
  
  ReDim sq(Application.RoundUp(UBound(sn) / 3, 0) - 1, 3)
  
  For j = 0 To UBound(sq)
    sq(j, 0) = "Auto " & j + 1
    sq(j, 1) = st(j + 1, 2)
    sn = Filter(sn, sq(j, 1), 0)
  Next
  
  For j = 0 To UBound(sp) - 1
    Debug.Print j + 1, sp(j + 1), sp(j + 1) - 1
     sq(j \ (UBound(sq, 2) - 1), j Mod (UBound(sq, 2) - 1) + 2) = sn(sp(j + 1) - 1)
  Next
  
  .Cells(2, 4).Resize(UBound(sq) + 1, UBound(sq, 2) + 1) = sq
End With
End Sub

snb · 3 jul 2017

Gebruik gewoon een stapeltje kaarten met namen.

Peter B · 3 jul 2017

^ Niet je beste idee

snb · 3 jul 2017

We spreken elkaar wel over een jaar (indalend inzicht gaat niet overal even snel).

Random auto indeling vereenvoudigen

Gebruiker

Terugkerende gebruiker

Verenigingslid

Gebruiker

Gebruiker

Verenigingslid

Terugkerende gebruiker

Gebruiker

Verenigingslid

Bijlagen

Gebruiker

Verenigingslid

Terugkerende gebruiker

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Wij waarderen jouw privacy