Dopo qualche tentativo abortito, probabilmente questo codice potrebbe funzionare:
- Codice: Seleziona tutto
Dim SorgBase As Range, DestBase As Range, LastP As String
Dim I As Long, Playrs As Long, J As Long, DLock As Long
Sub sort2()
Dim P1 As String, P2 As String, P3 As String, P4 As String
'
Set SorgBase = Sheets("ISCRITTI").Range("B4") '<<< L'area dove comincia l' elenco dei PLAYERS
Set DestBase = Sheets("SORTEGGI").Range("A4") '<<< L'area dove comincia l' elenco delle partite
Playrs = Range(SorgBase, SorgBase.End(xlDown)).Rows.Count
DLock = 0
reJ:
DestBase.Resize(Playrs, 9).ClearContents
DLock = DLock + 1
DoEvents
For J = 1 To 3
DoEvents
For I = 1 To Int(Playrs / 4)
ReP1: If DLock > 10 And DLock Mod 500 = 1 Then GoTo reJ Else If DLock > 10000 Then GoTo AbortA
P1 = SorgBase.Offset(Int(Rnd() * Playrs), 0).Value
If Not Buono(P1, 1) Then GoTo ReP1 Else DestBase.Offset(2 * (I - 1), 3 * (J - 1)).Value = P1
ReP2: If DLock > 10 And DLock Mod 500 = 1 Then GoTo reJ Else If DLock > 10000 Then GoTo AbortA
P2 = SorgBase.Offset(Int(Rnd() * Playrs), 0).Value
If Not Buono(P2, 2) Then GoTo ReP2 Else DestBase.Offset(2 * (I - 1) + 1, 3 * (J - 1)).Value = P2
ReP3: If DLock > 10 And DLock Mod 500 = 1 Then GoTo reJ Else If DLock > 10000 Then GoTo AbortA
P3 = SorgBase.Offset(Int(Rnd() * Playrs), 0).Value
If Not Buono(P3, 1) Then GoTo ReP3 Else DestBase.Offset(2 * (I - 1), 3 * (J - 1) + 1).Value = P3
ReP4: If DLock > 10 And DLock Mod 500 = 1 Then GoTo reJ Else If DLock > 10000 Then GoTo AbortA
P4 = SorgBase.Offset(Int(Rnd() * Playrs), 0).Value
If Not Buono(P4, 2) Then GoTo ReP4 Else DestBase.Offset(2 * (I - 1) + 1, 3 * (J - 1) + 1).Value = P4
Next I
Next J
MsgBox ("Completato")
Exit Sub
'
AbortA:
MsgBox ("Tentativo fallito")
End Sub
Function Buono(ByVal PLYR As String, ByVal CC As Long) As Boolean
Dim myPres As Long
'
Buono = False: DLock = DLock + 1
'If DLock > 1000 Then Stop
DoEvents
myPres = Application.WorksheetFunction.CountIf(DestBase.Offset(0, 3 * (J - 1)).Resize(Playrs / 2, 2), PLYR)
If myPres > 0 Then GoTo ExitA
If Left(PLYR, 1) = "%" And Left(LastP, 1) = "%" Then GoTo ExitA
If Left(PLYR, 1) = "*" And Left(LastP, 1) = "*" Then GoTo ExitA
If J > 1 And CC = 2 Then
If CkPair(PLYR, LastP) = False Then GoTo ExitA
End If
Buono = True: DLock = 0
If CC = 1 Then LastP = PLYR
ExitA:
'If DLock > [J1] Then [J1] = DLock
End Function
Function CkPair(ByVal PP As String, ByVal SP As String) As Boolean
Dim myI As Long, myJ As Long, myK As Long, CPP As Long, CSP As Long
CkPair = False
DoEvents
For myJ = 0 To J - 1
For myI = 0 To Int(Playrs / 4) * 2 Step 2
For myK = 0 To 1
DoEvents
CPP = Application.WorksheetFunction.CountIf(DestBase.Offset(myI, 3 * myJ).Resize(2, 1), PP)
CSP = Application.WorksheetFunction.CountIf(DestBase.Offset(myI, 3 * myJ).Resize(2, 1), SP)
If (CPP + CSP) = 2 Then GoTo ExitA
Next myK
Next myI
Next myJ
CkPair = True
ExitA:
End Function
Per usarla:
-Da excel, premi Alt-F11 per aprire l' editor delle macro; Menu /Inserisci /Modulo; copia il codice e incollalo nel frame di dx.
Adatta le istruzioni marcate <<<, per indicare:
-su quale foglio /cella comincia l' elenco dei giocatori
-su quale foglio /cella comincera' l' elenco delle accoppiate che saranno generate
Non inserire, nello stesso "Modulo" altre istruzioni.
Per usarla:
-da Excel, premi Alt-F8, scegli sort2 dall' elenco di macro che risultano disponibili, premi Esegui.
Se devi ripeterla frequentemente puo' essere utile creare un pulsante e associargli la macro:
-Menu /Tab Sviluppo /Gruppo Controlli /Inserisci; scegli il Pulsante tra i Controlli Modulo; disegna il pulsante e associagli la macro (ti verra' esplicitamente chiesto quale macro vuoi associare).
In questo modo bastera' premere il pulsante per rieseguire la macro.
Il risultato e' come da immagine (nomi e formattazione sono a fantasia mia):
free image hostingCioe':
Le coppie sono su stessa colonna, righe adiacenti (es A4:A5)
Le due "coppie accoppiate" sono su colonne adiacenti (es A e B)
Tra le partite c' e' una colonna libera (la C e la F, nell' esempio)
Fai sapere...
Registrazione
