Intanto
"Benvenuto nel forum"Quanto segue e' un "lavoro di forza", cioe' di prova e riprova fini ad avere i gruppi che soddisfano la regola.
Supponiamo che i concorrenti siano registrati in A2-B2 e sottostanti (le coppie nella stessa riga)
In F2 e sottostanti scrivi la dimensione dei gruppi che vuoi ritrovare, e nella colonna accanto scrivi quanti gruppi di quella dimensione vuoi creare. E' ovvio che devi fare in modo che gli iscritti richiesti per creare quei gruppi siano disponibili in colonne A:B
Per aiutarmi ho calcolato in E2 quanti iscritti sono presenti, usando la formula
- Codice: Seleziona tutto
=CONTA.VALORI(A2:B50)
(max 50 coppie)
Ho riservato l'area arancione alla dichiarazione della dimensione e del numero di gruppi
Avendo nel mio test 40 iscritti ho impostato 2 gruppi di 5 e 5 gruppi da 6
In H2 ho calcolato quanti iscritti servono per creare quei gruppi, usando la formula
- Codice: Seleziona tutto
=F3*G3+F2*G2+F4*G4+F5*G5
La verifica tra iscritti presenti e iscritti richiesti per creare quei gruppi va fatta a occhio, se hai paura di sbagliare puoi aggiungere una formattazione condizionale che evidenzia se i due valori (E2 e H2) sono diversi.
Creero' i gruppi a partire da L2: verso il basso i componenti del gruppo, verso destra i gruppi successivi
Ho inserito un ulteriore controllo nelle colonne C:D, per contare quante volte quell'iscritto e' presente nei risultati.
Per questo ho usato in C2 la formula
- Codice: Seleziona tutto
=CONTA.SE($L$2:$U$9;A2)
(ho supposto che creeremo max 10 gruppi; allarga l'intervallo L:U se pensi di avere piu' gruppi)
Poi copia C2 verso il basso, e la colonna C copiala in D
Dovra' essere verificato che ogni iscritto compare in un solo gruppo, e tutti gli iscritti compaiono in un gruppo (che corrisponde ad avere una coppia di 1 accanto a ogni coppia iscritta)
La macro che gestisce tutto questo:
- Codice: Seleziona tutto
Sub CreaGruppi()
Dim Definiz As String, Risult As String, Gruppi As Long
Dim I As Long, grCnt As Long, J As Long, K As Long
Dim PlaARR, dEst As Range, rndI As Long, dLock As Long
Dim myTim As Single, hMany As Long
'
Definiz = "F2"
Risult = "L1"
myTim = Timer
reTry:
Range(Risult).CurrentRegion.ClearContents
Beep
dLock = 0: grCnt = 0
PlaARR = Split(Application.WorksheetFunction.TextJoin("-", True, Range("A2:B50")), "-", , vbTextCompare)
Gruppi = Application.WorksheetFunction.CountA(Range(Definiz).Resize(20, 1))
For I = 1 To Gruppi
hMany = Range(Definiz).Offset(I - 1, 0).Value
For J = 1 To Range(Definiz).Offset(I - 1, 1).Value
For K = 1 To hMany
Set dEst = Range(Risult).Offset(0, grCnt)
Do
DoEvents
rndI = Int((UBound(PlaARR) + 1) * Rnd)
If PlaARR(rndI) <> "" And Left(PlaARR(rndI), 2) <> (CStr(grCnt) & "#") Then
If InStr(1, PlaARR(rndI), "#", vbTextCompare) > 0 Then
dEst.Offset(100, 0).End(xlUp).Offset(1, 0) = Mid(PlaARR(rndI), 3)
If Len(Mid(PlaARR(rndI), 3)) < 1 Then Stop
Else
dEst.Offset(100, 0).End(xlUp).Offset(1, 0) = PlaARR(rndI)
If Len(PlaARR(rndI)) < 1 Then Stop
End If
PlaARR(rndI) = ""
If Application.WorksheetFunction.IsEven(rndI) Then
If PlaARR(rndI + 1) <> "" Then PlaARR(rndI + 1) = grCnt & "#" & PlaARR(rndI + 1)
Else
If PlaARR(rndI - 1) <> "" Then PlaARR(rndI - 1) = grCnt & "#" & PlaARR(rndI - 1)
End If
Exit Do
Else
dLock = dLock + 1
End If
If dLock > 3000 Then
GoTo reTry
End If
If (Timer - myTim) > 30 Then
MsgBox ("Fallito")
Exit Sub
End If
Loop
Next K
grCnt = grCnt + 1
Next J
Next I
End Sub
Copia il codice e incollalo in un "Modulo standard" del tuo vba. Per come fare segui le informazioni che trovi qui:
viewtopic.php?f=26&t=103893&p=647675#p647675E' presente un timeout di 30 secondi; se entro questo tempo i gruppi non sono stati completati allora la macro termina con un messaggio di errore; e' probabile che se rilanci la macro sia piu' fortunato
Usa il foglio con i soli dati che ho detto, quindi eventuali tue elaborazioni falle in un foglio diverso
Fai sapere...
Registrazione
