Mi sono assentato un giorno e voi fate tutto senza di me? Sono verde dall' invidia...
(Devo pero' confessare che appena finito di scrivere il mio post precedente mi era parso evidente che la richiesta fosse diversa dalla risposta data
ma oramai non avevo tempo per cancellare il post).
Mosso dall' invidia ho googlato con "tournament schedule" e sono arrivato a un file che fa tutto con poche formule (!):http://www.box.com/s/z41sn0yrp5lo1cuozke3 (non c' e' traccia di chi sia l' autore)
L' ho voluto tradurre in macro aggiungendo qualche prestazione.
-si scrive l' elenco delle squadre in un elenco verticale (min 3 max 30 squadre)
-si scrive nella macro la cella di inizio dell' elenco
-si scrive nella macro la cella di inizio del report
-si lancia la macro Comb2a2
Nel caso ci sia un numero dispari di "partecipanti" viene aggiunta una voce "Rip"; nell' ipotesi che sia il calendario di un torneo ad ogni giornata ci sara' un incontro "Rip / Partecipante x"; significa che quel partecipante riposa.
Il calendario viene presentato occupando due celle per ogni incrocio; volendo si puo' modificare per raggruppare in una sola cella.
Il codice della macro:
- Codice: Seleziona tutto
Sub comb2a2()
Dim ListA1 As String, Dest As String, MyVArr, DynArr, Rispo, aaa
Dim LstList As Integer, Player As Integer, I As Integer, J As Integer
'Parametri
ListA1 = "A2" 'La cella dove comincia l' elenco dei componenti
Dest = "C2" 'l' area delle combinazioni
'
RePlayer:
LstList = Range(ListA1).Offset(100, 0).End(xlUp).Row
Player = LstList - Range(ListA1).Row + 1
If Player Mod 2 = 1 Then
Range(ListA1).Offset(Player) = "Rip"
GoTo RePlayer
End If
If Player < 4 Or Player > 30 Then
MsgBox ("Almeno 4 e max 30 Player (ora sono " & Player & "); operazione interrotta")
Exit Sub
End If
MyVArr = Range(ListA1).Resize(Player, 1).Value
Range(Dest).Resize(Player + 10, Player + 3).Select
Rispo = MsgBox("Ok per azzerare l' area selezionata?" & vbCrLf & _
"SI per continuare, NO per interrompere", vbYesNo)
If Rispo <> vbYes Then Exit Sub
Selection.Clear
Selection.Range("A1").Select
'inizializza dynArr
DynArr = Range(Dest).Resize(Player - 1, Player).Value
I = UBound(DynArr, 2)
For I = 0 To Player / 2 - 1
DynArr(1, 1 + I * 2) = 1 + I: DynArr(1, 1 + I * 2 + 1) = Player - I
Next I
For I = 2 To Player - 1
For J = 2 To Player
DynArr(I, J) = (DynArr(I - 1, J) - 3 + 2 * (Player - 1)) Mod (Player - 1) + 2
Next J
Next I
For I = 2 To Player - 1
DynArr(I, 1) = 1
Next I
'scrivi in Dest
For I = 1 To Player - 1
For J = 1 To Player
With Range(Dest).Offset(I - 1, J - 1)
.Value = MyVArr(DynArr(I, J), 1)
If Int((J - 1) / 2) Mod 2 = 0 Then .Interior.Color = RGB(0, 200, 200)
'Range(Dest).Resize(Player - 1, Player) = DynArr
End With
Next J
Next I
End Sub
Provate.
Ciao a tutti