Segui attentamente come dovrai impostare i fogli e i dati su di essi nel file:
1) per far funzionare la macro che posterò avrai bisogno di due fogli
uno con nome Elenco, l'altro con nome Gruppi
2) Nel foglio elenco dovrai avere Riga 1 la testata quindi in A1 scrivi "N", in "B1:C1" che unirai scriverai "Coppie", in E1 scriverai "Singoli"
3) Da A2 a A14 numeri sequenziali da 1 a 14 (non necessari ma servono per avere subito il numero delle coppie)
estremamente necessario invece è avere le coppie es.: in B2 "moreno" e C2 "annamaria"
quindi le coppie saranno elencate da B2 a C14
4) la colonna D deve essere vuota
5) nella cella E2 seguirà l'elenco dei Singoli E2 inserirai "alfredo", E3 roberta etc fino a E7 (silvia)
6) ora in G1 scrivi il testo "N. Gruppi" e in G2 inserirai una convalida con elenco di questo tipo
- Codice: Seleziona tutto
4;5;6;7;8
Così avrai la possibilità di scegliere la quantità di gruppi da 4 a 8
7) Nel foglio Gruppi potrai formattare le celle A1:B6 con bordo intermedio (fino) e poi bordatura doppia unendo solo le celle A1 e B1
8 ) copi questa formattazione per 7 volte lasciando una colonna (la C nella prima copia)
quindi copi il formato A1:B6 e lo incolli in D1:E6, poi in G1:H6 etc fino a V1:W6
ora puoi incollare questa macro in un modulo
- Codice: Seleziona tutto
Sub Distribuzione()
Set Ws1 = Sheets("Elenco")
Set Ws2 = Sheets("Gruppi")
NGr = Ws1.[G2]
Comb1 = 0
Comb2 = 0
Comb3 = 0
Coppie1 = 0
Coppie2 = 0
Coppie3 = 0
Sing1 = 0
Sing2 = 0
Sing3 = 0
Select Case NGr
Case 4
Comb1 = 3
Comb2 = 1
Comb3 = 0
Coppie1 = 3
Coppie2 = 4
Coppie3 = 0
Sing1 = 2
Sing2 = 0
Sing3 = 0
Case 5
Comb1 = 2
Comb2 = 2
Comb3 = 1
Coppie1 = 2
Coppie2 = 3
Coppie3 = 3
Sing1 = 2
Sing2 = 1
Sing3 = 0
Case 6
Comb1 = 1
Comb2 = 4
Comb3 = 1
Coppie1 = 3
Coppie2 = 2
Coppie3 = 2
Sing1 = 0
Sing2 = 1
Sing3 = 2
Case 7
Comb1 = 1
Comb2 = 4
Comb3 = 2
Coppie1 = 1
Coppie2 = 2
Coppie3 = 2
Sing1 = 2
Sing2 = 1
Sing3 = 0
Case 8
Comb1 = 1
Comb2 = 4
Comb3 = 3
Coppie1 = 2
Coppie2 = 2
Coppie3 = 1
Sing1 = 0
Sing2 = 0
Sing3 = 2
Case Else
Exit Sub
End Select
Ws2.Cells.ClearContents
Ws1.Range("D2:D14").ClearContents
Ws1.Range("F2:F7").ClearContents
Dim VC(13) As Integer
Dim VS(6) As Integer
NCR = 0
NSR = 0
InizioR:
If NCR = 13 Then GoTo EsciR
For RN = 1 To 13
NC = Int(Rnd(13) * 13) + 1
If Ws1.Range("D" & NC + 1) <> "" Then GoTo InizioR
Ws1.Range("D" & NC + 1) = NC
NCR = NCR + 1
VC(NCR) = NC
Next RN
EsciR:
InizioRS:
If NSR = 6 Then GoTo EsciRS
For RN = 1 To 6
NS = Int(Rnd(6) * 6) + 1
If Ws1.Range("F" & NS + 1) <> "" Then GoTo InizioRS
Ws1.Range("F" & NS + 1) = NS
NSR = NSR + 1
VS(NSR) = NS
Next RN
EsciRS:
CG = 1
SG = 1
NAGr = 0
For NCB1 = 1 To Comb1
Col = 1 + (NCB1 - 1) * 3
NAGr = NAGr + 1
Ws2.Cells(1, Col).Value = "Gruppo " & NAGr
For NCopp1 = 1 To Coppie1
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If CG < 14 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VC(CG) + 1, 2).Value
Ws2.Cells(URG, Col + 1).Value = Ws1.Cells(VC(CG) + 1, 3).Value
CG = CG + 1
End If
Next NCopp1
For NSing1 = 1 To Sing1
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If SG < 7 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VS(SG) + 1, 5).Value
SG = SG + 1
End If
Next NSing1
Next NCB1
For NCB2 = 1 To Comb2
Col = 1 + (NCB1 - 1) * 3 + (NCB2 - 1) * 3
NAGr = NAGr + 1
Ws2.Cells(1, Col).Value = "Gruppo " & NAGr
For NCopp2 = 1 To Coppie2
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If CG < 14 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VC(CG) + 1, 2).Value
Ws2.Cells(URG, Col + 1).Value = Ws1.Cells(VC(CG) + 1, 3).Value
CG = CG + 1
End If
Next NCopp2
For NSing2 = 1 To Sing2
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If SG < 7 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VS(SG) + 1, 5).Value
SG = SG + 1
End If
Next NSing2
Next NCB2
For NCB3 = 1 To Comb3
Col = 1 + (NCB1 - 1) * 3 + (NCB2 - 1) * 3 + (NCB3 - 1) * 3
NAGr = NAGr + 1
Ws2.Cells(1, Col).Value = "Gruppo " & NAGr
For NCopp3 = 1 To Coppie3
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If CG < 14 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VC(CG) + 1, 2).Value
Ws2.Cells(URG, Col + 1).Value = Ws1.Cells(VC(CG) + 1, 3).Value
CG = CG + 1
End If
Next NCopp3
For NSing3 = 1 To Sing3
URG = Ws2.Cells(Rows.Count, Col).End(xlUp).Row + 1
If SG < 7 Then
Ws2.Cells(URG, Col).Value = Ws1.Cells(VS(SG) + 1, 5).Value
SG = SG + 1
End If
Next NSing3
Next NCB3
Ws1.Range("D2:D14").ClearContents
Ws1.Range("F2:F7").ClearContents
End Sub
Per farla attivare in automatico devi inserire queste due righe di codice nel vba del foglio "Elenco"
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$G$2" Then Exit Sub
Distribuzione
Sheets("Gruppi").Select
End Sub
Salvi il file e poi cambia il valore del gruppo in G2, e...
Comunque capisco che distribuire i dati secondo specifiche si può errare pertanto allego il file già funzionante
download file completoFai sapere
ciao