Condividi:        

torneo calcio balilla

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

torneo calcio balilla

Postdi raimea » 11/11/10 21:24

sto cercando di adattare un file (gestito-fatto da questo forum),
per creare le coppie di un torneo di calcio-balilla.

(devo organiz. il torneo all'oratorio x i ragazzi in modo che non litighino o si
crei gia dall'inizio la coppia "vincente.....) :D

il file allegato, correttamente crea casualmente le "coppie" scegliendo solo dalla Col A.

a me servirebbe che crei le coppie casualmente, ma prendendo sempre un partec dalla col A e uno dalla Col B
in modo di avere le coppie casuali ma formate sempre da un portiere e un attaccante.

il Maximo sarebbe poter ritardare un attimo l'esito del sorteggio.... :)

riporto il file in questione.

http://www.sendspace.com/file/an1nm7

ringrazio in anticipo chi vorra' cimentarsi nella modifica, necessaria
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

Sponsor
 

Re: torneo calcio balilla

Postdi Flash30005 » 11/11/10 23:36

Il file da te allegato è un eseguibile che sinceramente non amo aprire se non conosco la provenienza
(ho da poco ripristinato il mio sistema per un HD difettoso e non vorrei ricominciare da capo)

Sarebbe opportuno che inviassi un file di excel con i concorrenti
la spiegazione che hai dato è sufficiente ma se hai delle specifiche da aggiungere a quanto detto
fallo al momento che invii il file per evitare di "rimettere le mani" su un programma che porterà via sicuramente del tempo per realizzarlo e renderlo funzionante.

Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: torneo calcio balilla

Postdi raimea » 12/11/10 07:14

okk ;)

riporto l'intera macro che al momento
sorteggia correttamente solo in col A

Codice: Seleziona tutto
   Public Gr, RR, MRR, Ngr, FGR As Integer
Sub Sorteggia()
Ngr = Range("G1").Value
Gr = 1
ContaGr = 0
Formato = 0
MRR = 2
UR = Range("A" & Rows.Count).End(xlUp).Row
UD = Range("C" & Rows.Count).End(xlUp).Row
If UD < 2 Then UD = 2
    Range("C2:E" & UD + 1).Clear
Ripeti:
For Each S In Range("C2:C" & UR)
If S.Value = 0 Then
UA = Range("D" & Rows.Count).End(xlUp).Row + 1
If UA < 2 Then UA = 2
salta:
Cas = Int(Rnd() * (UR + 1))
If Cas < 2 Then Cas = 2
If Range("C" & Cas).Value > 0 Then GoTo salta
ContaGr = ContaGr + 1
Range("C" & Cas).Value = Gr
If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
Range("D" & UA).Value = Range("A" & Cas).Value
End If
Next S
ContaV = 0
For TV = 2 To UR
If Range("C" & TV).Value = 0 Then
ContaV = ContaV + 1
End If
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
Formato = 1
For Each R In Range("C2:C" & UR)
    If R.Value = Gr Then
RUg:
    CasR = Int(Rnd() * Gr)
    If CasR = 0 Then GoTo RUg
    If MCasR = CasR Then GoTo RUg
    Range("C" & R.Row).Value = CasR
    MCasR = CasR
    End If
Next R
End If
Call SepGr
Call TrovaRForm
Range("D1").Select
End Sub
Sub SepGr()
UD = Range("C" & Rows.Count).End(xlUp).Row
    Range("C2:D" & UD).Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("D2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    Range("C1").Select

End Sub
Sub TrovaRForm()
UD = Range("C" & Rows.Count).End(xlUp).Row + 1
For TRF = 1 To Gr - 1
For RR = MRR To UD
If Range("C" & RR).Value <> TRF Then
Call FormGruppi
'TRF = Range("C" & RR).Value
GoTo SaltaR
End If
Next RR
SaltaR:
'If FGR = Gr Then GoTo esci
Next TRF
esci:
End Sub

Sub FormGruppi()

    Range("C" & MRR & ":D" & RR - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    MRR = RR
End Sub


mi bastano le richieste sopra riportate,
cioe' creare squadre con un concor a caso della col A con uno della Col B

solo se possibile ... dare un -ritardo- alla creazione delle saquadre,
tanto x creare suspance... :)

qui il file senza nessuna macro
http://www.sendspace.com/file/48xqae
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

Re: torneo calcio balilla

Postdi Flash30005 » 12/11/10 16:04

Sostituisci solo la macro "Sorteggia"
con questa macro

Codice: Seleziona tutto
Sub Sorteggia2()

Ngr = Range("G1").Value
Gr = 1
ContaGr = 0
Formato = 0
MRR = 2
UR = Range("A" & Rows.Count).End(xlUp).Row
URB = Range("B" & Rows.Count).End(xlUp).Row
UD = Range("C" & Rows.Count).End(xlUp).Row
If UD < 2 Then UD = 2
    Range("C2:E" & UD + 1).Clear
Ripeti:
For Each S In Range("C2:C" & UR + URB)
    If S.Value = 0 Then
        UA = Range("D" & Rows.Count).End(xlUp).Row + 1
        If UA < 2 Then UA = 2
        Start = Timer
        Pausa = 1
salta:
        Cas = Int(Rnd() * (UR + URB + 1))
        If Cas < 2 Then Cas = 2
        Col = 1
        Riga = Cas
        If Cas > UR Then
            Riga = Cas - UR
            Col = 2
        End If

        If Range("C" & Cas).Value > 0 Then GoTo salta

        If Timer < Start + Pausa Then GoTo salta
        ContaGr = ContaGr + 1
        Range("C" & Cas).Value = Gr
        If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
        Range("D" & UA).Value = Cells(Riga, Col).Value
    End If
Next S
ContaV = 0
For TV = 2 To UR + URB
If Range("C" & TV).Value = 0 Then
ContaV = ContaV + 1
End If
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
Formato = 1
For Each R In Range("C2:C" & UR + URB)
    If R.Value = Gr Then
RUg:
    CasR = Int(Rnd() * Gr)
    If CasR = 0 Then GoTo RUg
    If MCasR = CasR Then GoTo RUg
    Range("C" & R.Row).Value = CasR
    MCasR = CasR
    End If
Next R
End If
Call SepGr
Call TrovaRForm
Range("D1").Select
End Sub


Fai sapere
Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: torneo calcio balilla

Postdi raimea » 12/11/10 17:48

mmm :-?
ci siamo quasi
unico inghippo che al momento considera anche
la scritta "attaccante" in B1, lo mette nelle coppie
cioe' lo considera una persona
la macro deve cominciare a cercare tra i nomi da B2 anzicche da B1. :roll:
poi x il resto sembra tutto ok.
grazie
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

torneo calcio balilla

Postdi raimea » 12/11/10 20:47

oltre a quanto sopra riportato:
ho notato che non sempre crea la coppia
con un nome della col A & una della Col B
alcune coppie sono formate con nomi della stessa colonna.
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

Re: torneo calcio balilla

Postdi Flash30005 » 14/11/10 11:22

Ok
Prova questa macro che è casuale sia per la colonna A
(secondo me non occorre rendere casuale anche "A" quando lo è "B" rispetto ad "A", comunque...)
sia per la colonna B
Codice: Seleziona tutto
Public Gr, RR, MRR, Ngr, FGR, UR, UD As Integer
Sub SorteggiaA()
Ngr = Range("G1").Value
Gr = 1
ContaGr = 0
Formato = 0
MRR = 2
UR = Range("A" & Rows.Count).End(xlUp).Row
UD = Range("C" & Rows.Count).End(xlUp).Row
If UD < 2 Then UD = 2
    Range("C2:E" & UD + 1).Clear

Ripeti:
For Each S In Range("C2:C" & UR)
If S.Value = 0 Then
UA = Range("D" & Rows.Count).End(xlUp).Row + 1
If UA < 2 Then UA = 2
salta:
Cas = Int(Rnd() * (UR + 1))
If Cas < 2 Then Cas = 2
If Range("C" & Cas).Value > 0 Then GoTo salta
ContaGr = ContaGr + 1
Range("C" & Cas).Value = Gr
If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
Range("D" & UA).Value = Range("A" & Cas).Value
End If
Next S
ContaV = 0
For TV = 2 To UR
If Range("C" & TV).Value = 0 Then
ContaV = ContaV + 1
End If
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
Formato = 1
For Each R In Range("C2:C" & UR)
    If R.Value = Gr Then
RUg:
    CasR = Int(Rnd() * Gr)
    If CasR = 0 Then GoTo RUg
    If MCasR = CasR Then GoTo RUg
    Range("C" & R.Row).Value = CasR
    MCasR = CasR
    End If
Next R
End If
Call SorteggiaB
Range("I2:I" & UD + 1).Clear
Call SepGr
Call TrovaRForm
Range("D1").Select
End Sub

Sub SorteggiaB()

Gr = 1
ContaGr = 0
Formato = 0
MRR = 2

Ripeti:
For Each S In Range("I2:I" & UR)
If S.Value = 0 Then
UA = Range("E" & Rows.Count).End(xlUp).Row + 1
If UA < 2 Then UA = 2
salta:
Cas = Int(Rnd() * (UR + 1))
If Cas < 2 Then Cas = 2
If Range("I" & Cas).Value > 0 Then GoTo salta
ContaGr = ContaGr + 1
Range("I" & Cas).Value = Gr
If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
Range("E" & UA).Value = Range("B" & Cas).Value
End If
Next S
ContaV = 0
For TV = 2 To UR
If Range("I" & TV).Value = 0 Then
ContaV = ContaV + 1
End If
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
Formato = 1
For Each R In Range("I2:I" & UR)
    If R.Value = Gr Then
RUg:
    CasR = Int(Rnd() * Gr)
    If CasR = 0 Then GoTo RUg
    If MCasR = CasR Then GoTo RUg
    Range("I" & R.Row).Value = CasR
    MCasR = CasR
    End If
Next R
End If
End Sub
Sub SepGr()
UD = Range("C" & Rows.Count).End(xlUp).Row
    Range("C2:E" & UD).Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("D2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
    Range("C1").Select

End Sub
Sub TrovaRForm()
UD = Range("C" & Rows.Count).End(xlUp).Row + 1
For TRF = 1 To Gr - 1
For RR = MRR To UD
If Range("C" & RR).Value <> TRF Then
Call FormGruppi
GoTo SaltaR
End If
Next RR
SaltaR:
Next TRF
esci:
End Sub

Sub FormGruppi()

    Range("C" & MRR & ":E" & RR - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    MRR = RR
End Sub


Se va bene, poi faremo modificheremo qualcosa per creare suspance

Fai sapere
Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: torneo calcio balilla

Postdi raimea » 14/11/10 12:08

:D
ottimo funziona bene
se non e' troppo complicato
aggiungiamo la suspance.... :o
grazie
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

Re: torneo calcio balilla

Postdi Flash30005 » 14/11/10 13:14

Riporto tutte le macro anche se sono poche righe da aggiungere

Codice: Seleziona tutto
Public Gr, RR, MRR, Ngr, FGR, UR, UD, RS As Integer
Sub SorteggiaA()
Ngr = Range("G1").Value
Gr = 1
ContaGr = 0
Formato = 0
MRR = 2
RS = 1
UR = Range("A" & Rows.Count).End(xlUp).Row
UD = Range("C" & Rows.Count).End(xlUp).Row
If UD < 2 Then UD = 2
Range("C2:E" & UD + 1).Clear
Range("C2:E" & UD + 1).Font.ColorIndex = 2
Ripeti:
For Each S In Range("C2:C" & UR)
    If S.Value = 0 Then
        UA = Range("D" & Rows.Count).End(xlUp).Row + 1
        If UA < 2 Then UA = 2
salta:
        Cas = Int(Rnd() * (UR + 1))
        If Cas < 2 Then Cas = 2
        If Range("C" & Cas).Value > 0 Then GoTo salta
        ContaGr = ContaGr + 1
        Range("C" & Cas).Value = Gr
        If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
        Range("D" & UA).Value = Range("A" & Cas).Value
    End If
Next S
ContaV = 0
For TV = 2 To UR
    If Range("C" & TV).Value = 0 Then ContaV = ContaV + 1
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
    Formato = 1
    For Each R In Range("C2:C" & UR)
        If R.Value = Gr Then
RUg:
            CasR = Int(Rnd() * Gr)
            If CasR = 0 Then GoTo RUg
            If MCasR = CasR Then GoTo RUg
            Range("C" & R.Row).Value = CasR
            MCasR = CasR
        End If
    Next R
End If
Call SorteggiaB
Range("I2:I" & UD + 1).Clear
Call SepGr
Call TrovaRForm
Range("C1:E1").Select
Call Suspance
End Sub
Sub SorteggiaB()
Gr = 1
ContaGr = 0
Formato = 0
MRR = 2
Ripeti:
For Each S In Range("I2:I" & UR)
    If S.Value = 0 Then
        UA = Range("E" & Rows.Count).End(xlUp).Row + 1
        If UA < 2 Then UA = 2
salta:
        Cas = Int(Rnd() * (UR + 1))
        If Cas < 2 Then Cas = 2
        If Range("I" & Cas).Value > 0 Then GoTo salta
        ContaGr = ContaGr + 1
        Range("I" & Cas).Value = Gr
        If ContaGr Mod Ngr = 0 Then Gr = Gr + 1
        Range("E" & UA).Value = Range("B" & Cas).Value
        End If
Next S
ContaV = 0
For TV = 2 To UR
    If Range("I" & TV).Value = 0 Then ContaV = ContaV + 1
Next TV
If ContaV > 0 Then GoTo Ripeti
If ContaGr Mod Ngr <> 0 Then
    Formato = 1
    For Each R In Range("I2:I" & UR)
        If R.Value = Gr Then
RUg:
            CasR = Int(Rnd() * Gr)
            If CasR = 0 Then GoTo RUg
            If MCasR = CasR Then GoTo RUg
            Range("I" & R.Row).Value = CasR
            MCasR = CasR
        End If
    Next R
End If
End Sub
Sub SepGr()
UD = Range("C" & Rows.Count).End(xlUp).Row
    Range("C2:E" & UD).Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("D2") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
Range("C1:E1").Select
End Sub
Sub TrovaRForm()
UD = Range("C" & Rows.Count).End(xlUp).Row + 1
For TRF = 1 To Gr - 1
    For RR = MRR To UD
        If Range("C" & RR).Value <> TRF Then
            Call FormGruppi
            GoTo SaltaR
        End If
    Next RR
SaltaR:
Next TRF
End Sub

Sub FormGruppi()
    Range("C" & MRR & ":E" & RR - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    MRR = RR
End Sub

Sub Suspance()
UD = Range("C" & Rows.Count).End(xlUp).Row
Pausa = "00:00:01"   '<<<< qui determini l'attesa per la visualizzazione tra un dato e l'altro, impostato così è 1 secondo
RS = RS + 1
If RS > UD Then Exit Sub
Range("C" & RS & ":E" & RS).Font.ColorIndex = 1
Application.OnTime Now + TimeValue(Pausa), "Suspance"
End Sub


E questo è il file test

Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: torneo calcio balilla

Postdi raimea » 14/11/10 14:06

8)
ottimo
tutto ok
sistemo il file con altri accorgimenti che sono in grado
di sistemare da solo e poi metto on linee x tutti gli utenti .
grazie
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago

Re: torneo calcio balilla

Postdi raimea » 14/11/10 20:11

V 1.5
questo il file finale nel caso serva ad altri
grazie x l'aiuto... ;)

http://www.sendspace.com/file/o4ins0
S.O. win10, Excell 2019
Avatar utente
raimea
Utente Senior
 
Post: 1408
Iscritto il: 11/02/10 07:33
Località: lago


Torna a Applicazioni Office Windows


Topic correlati a "torneo calcio balilla":

Calcio
Autore: BrunoMarcio
Forum: Discussioni
Risposte: 1

Chi c’è in linea

Visitano il forum: Nessuno e 32 ospiti