Random lijsten

[Ravke]

Hallo,

Bij het aankomen van de eindejaarsfeesten stelde zich in de (grote) familie terug het probleem van het trekken van de briefjes om te bepalen wie voor wie een cadeau koopt. Nogal een bedoening als je de volgende voorwaarden moet voldoen: Een persoon kan niet voor zich zelf kiezen, en er mag niemand worden overgeslagen (of in de krijgerslijst komt meermals dezelfde naam voor). Een kluif voor Excel en VBA dacht ik, en maakte een procedure die deze keer wel perfect werkte, maar .... Er is een maar.

Het is voor de gebruiker van het bestandje eenvoudig te gebruiken, hij hoeft nl een lijstje met namen onder elkaar in te vullen op een blad, en daarna op de knop te drukken. het programmaatje controleert of er geen 2 maal dezelfde naam voorkomt (vb 2 X tante zonder verdere specs) en geeft een msgbox met het aantal ingevulde namen (kleine controle), waarna bij nog een druk op ok, een 2° kolom verschijnt met dezelfde namen, maar nooit naast elkaar en elke naam maar één maal.

Dank bij voorbaat

Ravke

Het essentiele om de randomlijst te maken zit hem in volgende deel:

Randomize
ReDim sq(antl - 1)

For j = 0 To UBound(sq)
sq(j) = Rnd
Next

For j = 0 To UBound(sq)
Cells(j + 5, 3) = WorksheetFunction.Match(WorksheetFunction.Small(sq, j + 1), sq, 0)
Next
....
antl = aantal namen (integer)

Nu is hiermee niet voldaan aan de voorwaarde dat er niet een naam van de eerste kolom weer op dezelfde rij terugkomt in de 2° kolom. Daarom controleer ik in dezelfde procedure dit. Het prog is zo dat de randomize wordt hervat totdat de fout niet meer voorkomt. Voor een lijstje van tot 30 personen is dat geen bezwaar, maar het bestandje moet meer kunnen (vb voor verenigingen, of loterijen). Het kan dus nogal lang duren eer een uitslag er is. Kan iemand mij een tip geven hoe dit vlotter kan?

 

[Wigi]

Hier mijn bijdrage in Excel VBA:

Sub OudjaarRandomNumbers_Wigi()
    
    Randomize
    
    sq = Application.Transpose([A1].CurrentRegion.Columns(1))
    
    For i = 1 To UBound(sq)
    
        If sq(i) <> "§" Then
            bstore = sq(i)
            sq(i) = "§"
        Else
            bstore = ""
        End If
        
        'sla lege matrix cellen over
        sq2 = Filter(sq, "§", False, 1)
        
        'random nummer
        rndn = Int(Rnd * (UBound(sq2) + 1))
        
        'output
        soutput = soutput & sq(WorksheetFunction.Match(sq2(rndn), sq, 0)) & "|"
        
        'verwijder uit lijst
        sq(WorksheetFunction.Match(sq2(rndn), sq, 0)) = "§"
        If Len(bstore) Then sq(i) = bstore
    
    Next
    
    sq3 = Application.Transpose(Split(soutput, "|"))
    [B1].Resize(UBound(sq3)) = sq3
    
End Sub

Heel quick & dirty, maar werkt vooralsnog wel. Ongeveer 4 seconden voor 1000 personen (zet die in kolom A). Persoonsnamen moeten uniek zijn.

Wigi

 

[Ravke]

Thanks, een 2° array met de waarde van de linkse kolom eruit gefilterd, dienend voor de rnd fuctie is niet dirty, maar heel goe gevonden.