(EXCEL) Macro per creare gruppi da elenco

[comet790]

Salve a tutti, ho bisogno di un aiuto per lo sviluppo di una macro excel:

Io ho due gruppi di nomi, uno di coppie e uno di singoli (che vorrei poter cambiare nel corso del tempo aggiungendo o sottraendo nomi), li vorrei suddividere, a mia scelta, o in gruppi di 7/8 persone (le coppie contano doppio) o in gruppi di 5 persone (sempre le coppie contano doppio).

ho già provato a modificare la macro suggerita in viewtopic.php?t=95591 ma non riesco ad adattarla alle mie esigenze.

Vi ringrazio in anticipo per l'aiuto!

[patel]

nella discussione linkata è stato chiesto un file di esempio con dati e risultato desiderato

[comet790]

Purtroppo non riesco ad allegare il file, comunque è un file molto banale nel foglio 1 sono presenti nella colonna B i nomi dei singoli e nella colonna D i nomi delle coppie. Le finalità mi pare di averle descritte bene, no?!

Grazie per l'aiuto

[alfrimpa]

Il file lo alleghi con un sito di file sharing tipo Filedropper, Dropbox o simili

[comet790]

Grazie, ecco il link http://www.filedropper.com/gruppi

[Anthony47]

Immagino che vuoi fare un mix casuale dei nominativi elencati
Con riferimento al tuo file, segna in G1 del foglio Elenco i numero di elementi per ogni gruppo, con tolleranza di +1 in caso di impossibilita' a suddividere esattamente; così se imposti 5 potra' succedere che uno o piu' gruppi siano da 6.
Poi in un modulo standard del vba inserisci questa macro:

Codice: Seleziona tutto

Sub aggruppa2()
Dim eUno As Long, eDue As Long, Elem As Long, gSize As Long, flRip As Boolean
Dim gCount As Long, cgCount As Long, Odds As Long, uArr() As Integer, Cas As Long
Dim cSize As Long

gSize = Sheets("Elenco").Range("G1")
eUno = Application.WorksheetFunction.CountA(Sheets("Elenco").Range("B:B")) - 1
eDue = Application.WorksheetFunction.CountA(Sheets("Elenco").Range("D:D")) - 1
Elem = eUno + 2 * eDue
gCount = Int(Elem / gSize)
Odds = Elem - gCount * gSize
ReDim uArr(1 To Elem)

Sheets("Gruppi").Cells.ClearContents
mytim = Timer
For I = 1 To gCount
    cSize = gSize
    If (gCount - I) < Odds And Odds > 0 Then cSize = cSize + 1
    For j = 1 To cSize
reCas:
        Cas = Int(Rnd() * (eUno + eDue)) + 1
reCheck:
        DoEvents
        If (Timer - mytim) > 10 Then Stop: mytim = Timer
        If uArr(Cas) <> 0 Then
            Cas = (Cas + 1) Mod (eUno + eDue + 1)
            If Cas = 0 Then Cas = 1
            flRip = True
        Else
            flRip = False
        End If
        If flRip Then GoTo reCheck
        If Cas > eUno And (cSize - j) < 1 Then GoTo reCas
        If Cas > eUno Then
            Sheets("Gruppi").Range("A1").Offset(100, I).End(xlUp).Offset(1, 0).Value = Sheets("Elenco").Range("D1").Offset(Cas - eUno, 0)
            j = j + 1
            two = True
        Else
            Sheets("Gruppi").Range("A1").Offset(100, I).End(xlUp).Offset(1, 0).Value = Sheets("Elenco").Range("B1").Offset(Cas, 0)
            two = False
        End If
        uArr(Cas) = Cas
        lastcas = Cas
    Next j
Next I
Exit Sub
Debug.Print "logger:"
For k = 1 To Elem
    If uArr(k) = 0 Then Debug.Print k
Next k
End Sub


La macro all'avvio CANCELLA SENZA PREAVVISO i contenuto del foglio Gruppi e poi provvede a generare gli N gruppi, che saranno elencati in verticale, da colonna B in avanti.

Ho l'impressione di averla fatta piu' complessa di quanto potrebbe servire, comunque spero ti sia di qualche aiuto.

Ciao

[comet790]

Ottimo, è proprio quello che mi serviva, grazie veramente!