Excel, Macro Assegnazioni casuali e non ripetute

[Pauwe]

Buongiorno a tutti,

ho un quesito da porvi per il quale non ho trovato ancora risposta.
Sono un amministratore di Forum dedicato a gare e campionati di Sim Racing.

Ho un file Excel con il quale assegno per ogni gara, una vettura in maniera randomica, ai piloti iscritti.
Vorrei fare in modo che non fosse possibile per i piloti ricevere una vettura che giá hanno avuto in gare precedenti.

Il numero di partecipanti é 20.
Il numero di vetture disponibili é variabile, ma nel campionato in corso é casualmente proprio 20 (sarebbe interessante una soluzione che preveda l'aumento di vetture disponibili, ma se non é possibile amen).
Il numero di gare é 6.

Al momento ho scritto una macro collegata ad un pulsante e che riporto qui sotto. Il suo "unico" problema é che non prevede ció che ho scritto sopra, ovvero potrebbe capitare che ad un pilota venga assegnata una vettura giá ricevuta per un altro Gran Premio;

Codice: Seleziona tutto

Private Sub CmdPiloti_Click()
Dim NumMin As Long
Dim NumMax As Long
Dim colIndex As Integer
Dim rwIndex As Integer
Dim IndexPiloti As Integer

IndexPiloti = CInt(Worksheets("Piloti").Range("P1").Value)

NumMax = 12345
NumMin = 1

'Pulisci la colonna da eventuali numeri giá scritti a mano
For rwIndex = 2 To 21
    For colIndex = IndexPiloti To IndexPiloti
        With Worksheets("Piloti").Cells(rwIndex, colIndex)
            .Cells.Value = ""
        End With
    Next colIndex
Next rwIndex

  'Inizializza il generatore di numeri casuali.
  Randomize

  For rwIndex = 2 To 21
    For colIndex = IndexPiloti To IndexPiloti
        With Worksheets("Piloti").Cells(rwIndex, colIndex)
              'genera il numero casuale
             RandomRange = Int((NumMax - NumMin + 1) * Rnd + NumMin)
            .Cells.Value = RandomRange
        End With
    Next colIndex
  Next rwIndex

   'Ordina la colonna dal valore piú grande al piú piccolo
    Range(Cells(1, IndexPiloti - 1), Cells(21, IndexPiloti)).Select
    ActiveWorkbook.Worksheets("Piloti").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Piloti").Sort.SortFields.Add Key:=Range(Cells(2, IndexPiloti), Cells(21, IndexPiloti)) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Piloti").Sort
        .SetRange Range(Cells(1, IndexPiloti - 1), Cells(21, IndexPiloti))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    'Aggiorna l'index
    IndexPiloti = IndexPiloti + 2
    Worksheets("Piloti").Range("P1").Value = IndexPiloti
         
   
    Range(Cells(1, IndexPiloti - 1), Cells(1, IndexPiloti - 1)).Select
    End Sub



Allego anche screen (molto spartano perdonatemi), per fare vedere il risultato graficamente.
https://imgur.com/a/7Bp9AfH

Nella prima colonna ci sarebbero i nomi dei piloti "umani" come me (li ho oscurati io).
Le altre colonne sono le varie gare. In rosso ho evidenziato i casi che vorrei evitare.

Grazie a tutti, a disposizione per qualunque cosa.

Saluti,
Manuel

[Anthony47]

Ciao Pauwe, benvenuto nel forum.

La macro che hai allegato e' strettammente relazionata alla struttura dei tuoi dati; senza e' inutilizzabile.
Puoi quindi allegare un file di esempio su cui poter lavorare e testare quanto sviluppato?

Per le istruzioni su come allegare un file:
viewtopic.php?f=26&t=103893&p=605487#p605487

Ti aspettiamo...

[Pauwe]

ciao, posso mettere direttamente il mio file? non ho niente da nascondere ovviamente.

http://www.filedropper.com/sorteggifc11

Se non va bene cosí e ne devo fare uno ad-hoc, fatemi sapere.

P.S. Come mai i messaggi originali non sono Editabili? É una scelta "aziendale" o é un errore?

[Pauwe]

Allego anche screen (molto spartano perdonatemi), per fare vedere il risultato graficamente.
https://imgur.com/a/7Bp9AfH

Nella prima colonna ci sarebbero i nomi dei piloti "umani" come me (li ho oscurati io).
Le altre colonne sono le varie gare. In rosso ho evidenziato i casi che vorrei evitare.

L'ho ripostata su PostImage, scusate.

[Pauwe]

nel file che ho allegato, il foglio in questione é l'ultimo, denominato "Piloti".

[Anthony47]

Non ho capito dove si trova l'elenco delle Auto da assegnare, quindi me lo sono inventato all'interno del foglio Appoggio da A2 verso il basso. Ne' ho capito a che servono le varie macro presenti nel file e l'architettura complessiva del file; quindi ho fatto finta che non mi interessano.

Poi per il sorteggio penso si possa usare la seguente macro

Codice: Seleziona tutto

Sub Assegna()
Dim CList As Range, AllC As Range, RList As Range, CRArea As Range, CDArea As Range
Dim I As Long, LastR As Long, J As Long, CNum As Long, RNum As Long
Dim myTim As Single, myT0 As Single, IJ As Long, BJ As Long
'
Set CList = Sheets("Appoggio").Range("A2")      '<<< L'inizio dell'elenco CAR
Set RList = Sheets("Piloti").Range("B2:B21")    '<<< L'area della prima gara
'
RList.Parent.Select                             'Parte dal foglio Races
Set AllC = Range(CList, CList.End(xlDown))
CNum = AllC.Rows.Count
LastR = RList.Cells(1, 1).Offset(-1, 40).End(xlToLeft).Column
BJ = RList.Cells(1, 1).Column
myT0 = Timer
re0:                            'Rerun se hungup 1 sec
Randomize
If (Timer - myT0) > 20 Then
    MsgBox ("Nessuna soluzione dopo 20 secondi; riprova")
    Exit Sub
End If
For J = BJ To LastR Step 2
    myTim = Timer
    Set CRArea = Cells(RList.Cells(1, 1).Row, J).Resize(RList.Rows.Count)
    CRArea.Resize(, LastR - J + 1).ClearContents
    For I = 1 To RList.Rows.Count
        Set CDArea = RList.Cells(I, 1).Resize(1, IJ * 2 + 1)    'C.D.Area
reRn:
        If (Timer - myTim) > 0.7 Then GoTo re0                    'Hungup?
        DoEvents
        RNum = Int(Rnd() * CNum) + 1                            'Sorteggia
        CRArea.Cells(I, 1).Value = AllC.Cells(RNum, 1)          'Assegna
        If Application.WorksheetFunction.CountIf(CRArea, AllC.Cells(RNum, 1)) > 1 Then
            GoTo reRn                                           'duplicato Vert
        End If
        If Application.WorksheetFunction.CountIf(CDArea, AllC.Cells(RNum, 1)) > 1 Then
            Beep                                                'duplicato Hor
            GoTo reRn
        End If
    Next I
    IJ = IJ + 1
Next J
MsgBox ("Fine sorteggio")
End Sub


Il codice va messo su un Modulo standard del vba. Le istruzioni marcate <<< vanno personalizzate come da commento.
In particolare con Set Clist si imposta la posizione di inizio della lista Autovetture; mentre con Set Rlist si imposta la posizione della prima gara.
Affinche' la macro funzioni regolarmente, la riga prima di quelle che imposti in Set Rlist -quindi Riga1, se si usa Range("B2:B21")– deve essere vuota alla destra dell'ultima gara inserita; quindi, nell'esempio pubblicato, le colonne da M in avanti vanno ripulite. Questo consente di identificare quale e' l'ultima gara da sorteggiare.
Inoltre le Gare si devono susseguire ogni 2 colonne (come nell'esempio pubblicato; la colonna intermedia la ignoro)
E comunque non si possono inserire piu' di 20 gare.

E' ovvio che se le Auto sono in numero inferiore ai piloti la macro non trovera' nessuna soluzione e si fermera' per timeout dopo 20 secondi.
E' meno ovvio che potrebbero esserci delle combinazioni che ostacolano la soluzione dell'equazione (assegnare allo stesso pilota sempre un'auto diversa; non assegnare nelle stessa gara la stessa Auto a due piloti). La macro cerca di gestire queste situazioni con una sequenza di retry, a livello di singola Gara o a livello di blocco completo. Se dopo 20 secondi non trova una soluzione si arrende e lascia il compito all'utente di riprovarci. Nelle mie prove la cosa e' successa ma nella grande maggioranza dei casi il sorteggio si e' completato.
Se invece il numero di Auto e superiore al numero di piloti allora questa situazione diventa rarissima

I messaggi pubblicati possono essere editati per 15 minuti dopo la loro pubblicazione, dopo puoi solo accodare un messaggio nuovo.

Prova e fai sapere...

[Pauwe]

Ok ora verifico. Le auto da sorteggiare erano nel Foglio "Piloti", ma leggendo la tua risposta immagino che tu ti aspettassi un foglio con solo una "lista" univoca. Chiedo scusa.
Intanto grazie, dopo il test ti faccio sapere se mi serve altro o se siamo a posto cosí!

[Pauwe]

Ciao, mi dava un errore di metodo Range praticamente subito, ma l'ho risolto e ora funziona tutto.
Una cortesia, se si puó.
Al momento il file calcola tutte le gare insieme.
Sarebbe possibile calcolare una gara alla volta?
Ho associato la macro ad un pulsante, quindi indicativamente mi piacerebbe sorteggiare una gara diversa (quella successiva) ogni volta che lo premo.

ciao e grazie, mi hai risolto un grande problema.

[Pauwe]

Per correttezza inserisco cosa ho modificato per farla funzionare (subito dopo le Dim);

Tua macro:
Set CList = Sheets("Appoggio").Range("A2") '<<< L'inizio dell'elenco CAR
Set RList = Sheets("Piloti").Range("B2:B21") '<<< L'area della prima gara
'
RList.Parent.Select 'Parte dal foglio Races
Set AllC = Range(CList, CList.End(xlDown))

Mia Macro:
Set CList = Sheets("Appoggio").Range("A2") '<<< L'inizio dell'elenco CAR
Set RList = Sheets("Piloti").Range("B2:B21") '<<< L'area della prima gara
'
CList.Parent.Select 'Parte dal foglio Appoggio
Set AllC = Sheets("Appoggio").Range("A2:A21")


Ho provato a lasciare il select sul foglio Piloti ma non c'é stato verso di farlo funzionare, limite mio sicuramente.
Ancora mille grazie.

[Anthony47]

Come detto nel primo messaggio, e' assolutamente possibile che all'estrazione N non ci sia nessuna combinazione che soddisfi ambedue le regole:
- assegnare allo stesso pilota sempre un'auto diversa
- non assegnare nelle stessa gara la stessa Auto a due piloti
Questo come conseguenze di scelte avvenute nelle estrazioni precedenti.

Il suddetto rischio e' alto se il numero di Auto e' pari al numero dei Drivers; ti accorgi di queste situazioni perche' vedi che la macro ricomincia le estrazioni daccapo.
Si riduce, ma non si annulla, man mano che il numero di auto aumenta in proporzione ai drivers.

Pertanto l'unico modo per garantire il risultato e' creare un tabellone globale.

Se vuoi simulare un'estrazione alla volta, allora crei il tabellone completo e poi di volta in volta vai a prendere la lista di una gara.

Con la modifica Set AllC = Sheets("Appoggio").Range("A2:A21") la macro considerera' che ci siano solo 20 auto; con l'istruzione originale invece l'elenco puo' essere allungato e la macro si adatta al numero di Auto da assegnare.
Mi spieghi meglio quale era l'errore che ottenevi?

Ciao

[Pauwe]

Intanto ancora grazie per le risposte.
questo é l'errore che ricevo:
https://i.postimg.cc/rFqXpwTT/errore-macro.png

Ad ogni modo non ci perdere il sonno, se ho bisogno allungo il Range e non c'é problema.
per quanto riguarda la domanda di sorteggio "uno alla volta" non fa niente, mi arrangio io.

Grazie!
Preziosissimo. C'é modo di lasciarti un feedback positivo?

[wallace&gromit]

scusate se mi intrometto, ma non è imaginabile un sistema in cui si esegue solo la prima estrazione e poi, di volta in volta l'auto attribuita viene decalata di una riga? In questo modo si sarebbe certi di avere sempre soluzioni in cui le auto appaiono una volta sola e fino alla fine del ciclo nessuno avrà di nuovo la stessa auto.

[Anthony47]

La proposta di W&G e' certamente bella e semplice da adottare (vedi sopra), se non c'e' il bisogno della aleatorieta' dell'accoppiamento nelle singole gare.

Quanto all'errore segnalato, ce l'hai perche' non hai seguito le istruzioni relative all'uso della Sub Assegna; in particolare "Il codice va messo su un Modulo standard del vba".
Invece lo hai messo nel "Modulo (di classe) di Foglio5=Piloti".

Quindi:
-dal vba creati un Modulo standard: Menu /Inserisci /Modulo
-copia il codice della Sub Assegna e incollalo in questo nuovo modulo
-torna sul modulo di Foglio5, dove c'e' il codice della Sub Sorteggio_Piloti_Click
-elimina tutto il codice (eccetto la prima riga ed End Sub) e sostituiscilo con

Codice: Seleziona tutto

Call Assegna

Ciao

[Pauwe]

ok grazie, ho inteso male.

[Anthony47]

Ricorda di valutare quanto proposto da W&G...