ESTRAZIONE NOME GIOCATORE DA ELENCO

[lextat]

Dunque appena rientrato da gita domenicale con famiglia giusto in tempo per vedere la Juve , ho appena dfato un okkio e modificato la macro come da te indicato sembra funzionare come volevo .. Dopo che viene interrotta e riavviata chiede se si vuol resettare .. Perfetto ...

La seconda parte (per la quale gia ti ringrazio) devo un po' capirla e cercherò di farlo , dopo la Juve ..

Lex

[Flash30005]

La seconda parte è semplice
se nel combox a finestra lasci "Tutti i Team"
avrai il sorteggio dei giocatori e squadre indipendentemente dal team di appartenenza
quindi potrà uscire
Pippo Juventus Teampaperopoli
Paperino Milan Disney
etc
mentre se selezioni un Team nel combox
il sorteggio sarà relativo ai soli giocatori di quel team

Dopo aver sorteggiato tutti i giocatori (un messaggio avvisa che non ci sono altri giocatori di quel Team)
puoi cambiare Team e avrai un nuovo sorteggio di questo team
senza cancellare il precedente sorteggio
Il reset invece cancella tutto

ciao

[lextat]

Ho trovato tutto quello che volevo nel software gratuito FANTA ASTA (su fantagazzeetta.c*m)

grazie comunque dell'aiuto Flash..

alla prossima

Lex

[Flash30005]

Più volte diciamo di effettuare sempre una ricerca di ciò che si vorrebbe, specialmente quando trattasi di programmi per i giochi popolari,
per due motivi
1) perché di programmi ormai ce ne sono talmente tanti chee l'utente trova molto di più di quanto avrebbe immaginato
2) si evita di perdere e far perdere tempo

Altra cosa è, invece, la sperimentazione...

Ciao

[Naus]

Ok allora usa questa macro

Codice: Seleziona tutto

Sub NomiCasuali()
Set Ws1 = Worksheets("Foglio1")
Set Ws2 = Worksheets("Foglio2")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Randomize (Timer)
For NC = 2 To UR1
    UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    If UR2 - 1 = UR1 Then
    MsgBox "Non ci sono altri nomi da estrarre"
    Exit Sub
    End If
Casuale:
    Ncas = Int(Rnd() * UR1) + 1
    If Ncas < 2 Then
        GoTo Casuale
    Else
        For RC2 = 2 To UR2
            If Ws2.Range("A" & RC2).Value = Ws1.Range("A" & Ncas).Value Then GoTo Casuale
        Next
    End If
Ws2.Range("A" & UR2).Value = Ws1.Range("A" & Ncas).Value
Ws2.Range("B" & UR2).Value = Ws1.Range("B" & Ncas).Value
Exit For

Next NC
End Sub

Sub CancellaSorteggio()
Set Ws1 = Worksheets("Foglio1")
Set Ws2 = Worksheets("Foglio2")
Ws2.Columns(1).ClearContents
Ws2.Columns(2).ClearContents
Ws2.Range("A1").Value = Ws1.Range("A1").Value
Ws2.Range("B1").Value = Ws1.Range("B1").Value
Call NomiCasuali
End Sub


Abbina un comando o forma alla macro "NomiCasuali"
e un altro comando o Forma alla macro "CancellaSorteggio"

Ciao

Ciao Flash30005,
ho letto questo post e ho utilizzato il codice da te postato per fare l'estrazione di 11 settori composti composti da 5 coppie di atleti. La macro funziona egregiamente ma vorrei implementare alcune condizioni quando viene fatta l'estrazione casuale. Le 55 coppie appartengono a 13 società differenti e nel limite del possibile vorrei che gli atleti della stessa società non vengano sorteggiati nello stesso settore. Inoltre essendo il campionato di 3 prove sarebbe bello che nelle successive prove non ci fossero degli abbinamenti già avuti nei sorteggi precedenti.
Un grazie in anticipo a te e a tutti gli utenti che vorranno aiutarmi

[Flash30005]

Ciao Naus e benvenuto nel Forum

Cambiando le esigenze cambia un po' tutto e non perdo tempo nemmeno a cercare il file che inviai 3 anni fa in quanto sarebbe solo una perdita di tempo mentre ti consiglio di:
1) preparare un foglio con i tuoi dati
2) inserire la macro che hai trovato
3) verificare cosa fa e cosa, invece ti aspetteresti che facesse
4) scrivere le note sul foglio con esempi esplicativi (esempi che riporterai anche nel post)
5) alleghi, al prossimo post, il foglio completo di quanto specificato nei punti 1-4

ciao

[Naus]

Ciao Flash30005,
ho preparato tutto e spero di avere fatto per bene i compiti a casa.
Di seguito allego il file con le relative note e spero di aver spiegato per bene le mie necessità. Rimango a disposizione per chiarimenti e correzioni a quanto fatto.

http://www.filedropper.com/estrai

Ciaooo

[Flash30005]

Ho scaricato il file ma non trovo nessuna indicazione

Proverò a capire da ciò che avevi scritto avendo la struttura dei dati
Ho provato a lanciare la macro ma non terminava il processo e l'ho fermata
mi sembra che occorra un tempo notevole e non vorrei che andasse in loop

tu l'hai provata e funziona?

[Flash30005]

Ho trovato le indicazioni in fondo al foglio...
Il non far inserire due coppie della stessa società nello stesso settore si può fare ma chiaramente il numero delle coppie/concorrenti di una società non deve superare il numero dei settori disponibili.

Vorrei, però, capire cosa intendi per

sarebbe bello che nelle successive prove non ci fossero degli abbinamenti già avuti nei sorteggi precedenti

ciao

[Naus]

Ciao Flash30005
e grazie per già dato un occhio al file che ho postato. Il file inizialmente faceva un solo sorteggio e funzionava bene, poi aggiungendo i pulsanti e ulteriori settori devo aver compromesso qualcosa e stamattina anche io mi sono accorto che non mi fa più il sorteggio1. Chiedo scusa per aver fatto l'upload senza aver verificato nuovamente che tutto funzionasse. Stasera vedo di sistemare il file e di fare un nuovo upload

Ho trovato le indicazioni in fondo al foglio...
Il non far inserire due coppie della stessa società nello stesso settore si può fare ma chiaramente il numero delle coppie/concorrenti di una società non deve superare il numero dei settori disponibili.

Naturalmente se una società presenterà più di 11 coppie l'abbinamento di 2 coppie nello stesso settore sarà inevitabile.

Vorrei, però, capire cosa intendi per

sarebbe bello che nelle successive prove non ci fossero degli abbinamenti già avuti nei sorteggi precedenti

ciao

Mi piacerebbe che le cinque coppie del settoreX estratte al primo sorteggio, nei futuri sorteggi non si trovino nuovamente nello stesso settore per fare in modo che nel limite del possibile tutti abbiamo diversi avversari per ogni sorteggio.

Spero di essere stato chiaro.

[Naus]

Il file inizialmente faceva un solo sorteggio e funzionava bene, poi aggiungendo i pulsanti e ulteriori settori devo aver compromesso qualcosa e stamattina anche io mi sono accorto che non mi fa più il sorteggio1. Chiedo scusa per aver fatto l'upload senza aver verificato nuovamente che tutto funzionasse. Stasera vedo di sistemare il file e di fare un nuovo upload

Ho rivisto il file ed eliminando l'unione celle dove ho inserito le note funziona anche il sorteggio1. Aggiungo anche che adesso il sorteggio viene fatto estraendo un nome per volta e mi serve per verificare ed eventualmente spostare manualmente concorrenti estratti della stessa società nello stesso settore nel settore successivo, ma che in futuro l'estrazione completa avvenga con un solo click.

Grazie ancora e buona giornata

[Flash30005]

Ho risolto la distribuzione univoca delle società in ogni settore
ora devo vedere come fare per evitare che due coppie si incontrino di nuovo nel medesimo settore

porta pazienza

ciao

[Naus]

Che dire Flash30005,
per ora grazie per il tempo che mi stai dedicando

[Flash30005]

Apri un nuovo file di Excel (completamente vuoto per evitare ci siano resumi di codici e altro)
Aggiungi 2 fogli
Rinomina i 5 fogli in questa maniera
Foglio1 con questo nome "Riepilogo_Iscrizioni"
Foglio2 con questo nome "Anagrafica"
Foglio3 con questo nome "Sorteggio1"
Foglio4 con nome "Sorteggio2"
Foglio5 con "Sorteggio3"
Nel foglio Anagrafica testata
in B1 scriverai "Nome Coppia"
in C1 scriverai "Società"
quindi da B2 a B56 i nomi delle coppie
e da C2 a C56 le società di appartenenza
Ora in un modulo inserirai l'intero codice qui riportato

Codice: Seleziona tutto

Public ContaT, ContrTeam, ColS, NumG, SMax As Integer, Foglio As String, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet, Sett As String
Private Sub CreaRiepilogo()
ColS = 3
Foglio = "Anagrafica"
Set Ws2 = Worksheets(Foglio)
URC = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Riga = 1
For RRC = 2 To URC
Ws2.Range("A" & RRC).Value = Riga
Riga = Riga + 1
Next RRC

URC = Ws2.Range("A" & Rows.Count).End(xlUp).Row - 1
NumG = URC
If NumG Mod 5 <> 0 Then
    MsgBox "Errato Numero Garisti (non divisibile per 5) ", vbCritical
    Exit Sub
End If
UR2 = Ws2.Range("C" & Rows.Count).End(xlUp).Row
Set Ws1 = Worksheets("Riepilogo_Iscrizioni")
Ws1.Columns("A:C").ClearContents
Ws1.Range("B1").Value = "Nome Coppia"
Ws1.Range("C1").Value = "Società"
ContaG = 0
For RR2 = 2 To UR2
G = Ws2.Range("C" & RR2).Value
G2 = Ws2.Range("C" & RR2 + 1).Value
If G = G2 Then
ContaG = ContaG + 1
Else
RR1 = Ws1.Range("B" & Rows.Count).End(xlUp).Row + 1
Ws1.Range("A" & RR1).Value = RR1 - 1
Ws1.Range("B" & RR1).Value = Ws2.Range("C" & RR2).Value
Ws1.Range("C" & RR1).Value = ContaG + 1
ContaG = 0
End If

Next RR2

End Sub
Sub IniEstr()
'01 Macro sorteggio iniziale
CreaRiepilogo
Dim CheckNomi As Long
Set Ws1 = Worksheets("Riepilogo_Iscrizioni")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
ColS = 3
Foglio = "Anagrafica"
Set Ws2 = Worksheets(Foglio)
URC = Ws2.Range("A" & Rows.Count).End(xlUp).Row - 1
NumG = URC
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
CheckNomi = 0
For RR2 = 2 To UR2
 Soc = Ws2.Cells(RR2, 3).Value
   For RR1 = 2 To UR1
   If Soc = Ws1.Cells(RR1, 2).Value Then CheckNomi = CheckNomi + 1
   Next RR1
Next RR2
SMsg = "Ci sono N. " & NumG - CheckNomi & " Nomi Errati"
If NumG - CheckNomi = 1 Then SMsg = "C'è un Nome Errato"
    If CheckNomi <> NumG Then
        MsgBox SMsg & " nel foglio " & Foglio, vbCritical
        Exit Sub
    End If
    Set ws3 = Worksheets("Sorteggio1")
    Set ws4 = Worksheets("Sorteggio2")
    Set ws5 = Worksheets("Sorteggio3")
If ws3.Range("D2").Value <> "" And ws4.Range("D2").Value <> "" And ws5.Range("D2").Value <> "" Then
    Messaggio = MsgBox(Prompt:="Vuoi Resettare le precedenti estrazioni ?", Buttons:=vbYesNo)
    If Messaggio = 6 Then
        Sett = "Sorteggio1"
        CancellaSorteggio
    End If
Else
    If ws3.Range("D2").Value <> "" And ws4.Range("D2").Value = "" Then
        MsgBox "Procedo con il 2° Sorteggio"
        Sett = "Sorteggio2"
        NomiCasuali
        Sorteggia
        FormTab
    Else
        If ws3.Range("D2").Value <> "" And ws4.Range("D2").Value <> "" And ws5.Range("D2").Value = "" Then
            MsgBox "Procedo con il 3° Sorteggio"
            Sett = "Sorteggio3"
            NomiCasuali
            Sorteggia
            FormTab
        Else
            Sett = "Sorteggio1"
            CancellaSorteggio
        End If
    End If
End If
Msga = " Sorteggio Avvenuto " & vbCrLf
Msga = Msga & " Vuoi assegnare Inizio Settori? "
Risp = MsgBox(Msga, vbYesNo)
If Risp = 6 Then SortIni
End Sub
Sub CancellaSorteggio()
Worksheets("Sorteggio1").Columns("A:D").Clear
Worksheets("Sorteggio2").Columns("A:D").Clear
Worksheets("Sorteggio3").Columns("A:D").Clear
Worksheets("Anagrafica").Columns("E:G").Clear
NomiCasuali
Sorteggia
FormTab
End Sub
Private Sub NomiCasuali()
SMax = NumG / 5
Set Ws1 = Worksheets("Riepilogo_Iscrizioni")
Set Ws2 = Worksheets(Foglio)
Ws1.Columns("O:T").ClearContents
Ro = 1
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
For RR1 = 2 To UR1
NGSo = Ws1.Cells(RR1, ColS).Value
If NGSo <> "" Then
Ws1.Range("O" & Ro).Value = Ws1.Range("B" & RR1).Value
Ws1.Range("P" & Ro).Value = NGSo
    Ws1.Range("Q" & Ro).FormulaR1C1 = "=IF(INT(RC[-1]/" & SMax & ")=0,RC[-1]," & SMax & " -MOD(RC[-1]," & SMax & "))"
    Ws1.Range("R" & Ro).FormulaR1C1 = "=IF(INT(RC[-2]/" & SMax & ")=0,1,INT(RC[-2]/" & SMax & "))"
        Ws1.Range("S" & Ro).FormulaR1C1 = "=" & SMax & "-RC[-2]"
    Ws1.Range("T" & Ro).FormulaR1C1 = "=IF(RC[-1]=0,0,(RC[-4]-RC[-2]*RC[-3])/RC[-1])"

   
Ro = Ro + 1
End If
Next RR1
Ws1.Select
    Columns("O:T").Sort Key1:=Range("P1"), Order1:=xlDescending, Key2:=Range("O1") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
        :=xlSortNormal
        Ws2.Columns("P:Q").ClearContents
For RRA = 1 To SMax
    Ws2.Range("P" & RRA).Value = RRA
    Ws2.Range("Q" & RRA).FormulaR1C1 = "=COUNTIF(C[-13],RC[-1])"
Next RRA
End Sub
Private Sub Sorteggia()
Dim ContaEx As Integer
Set Ws1 = Worksheets("Riepilogo_Iscrizioni")
Set Ws2 = Worksheets(Foglio)
Inizio:
VM = Evaluate("=SUM(COUNTIF(Riepilogo_Iscrizioni!P1:P5,"">=" & SMax & """))")
Ws2.Select
Ws2.Columns("D").ClearContents
URO = Ws1.Range("O" & Rows.Count).End(xlUp).Row
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR1 = 1 To URO
ContaEx = 0
    Soc = Ws1.Range("O" & RR1).Value
    NumGS = Ws1.Range("P" & RR1).Value
    For RR2 = 2 To UR2
        If Worksheets(Foglio).Range("C" & RR2).Value = Soc Then
            RigaI = RR2
            RigaF = RR2 + NumGS - 1
            Exit For
        End If
    Next RR2
    Randomize (Timer)
CC1 = 20
If Ws1.Cells(RR1, CC1).Value = 0 Then GoTo SaltaCC2
NCasuale0:
NNS = Ws1.Cells(RR1, CC1 - 1).Value
For NS = 1 To NNS
Ncasuale:
 If Evaluate("=Count((" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "))") = NumGS Then
    GoTo SaltaRR1
 End If
    NCas = Int(Rnd() * RigaF) + 1
    If NCas < RigaI Then GoTo Ncasuale
    If Ws2.Range("D" & NCas).Value <> "" Then GoTo Ncasuale
NTcas:
    NcasS = Int(Rnd() * SMax) + 1
If Ws1.Cells(RR1, CC1).Value = 0 Then GoTo SaltaCC1
    MyC = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D2:D" & UR2 & "," & NcasS & "))")
    If MyC = 5 Then GoTo NTcas
ContaEx = ContaEx + 1
If ContaEx > 500 Then GoTo Inizio
    MMM = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "," & NcasS & "))")
    NewMin = Evaluate("=MIN(" & "'" & Foglio & "'" & "!Q" & 1 & ":Q" & SMax & ")")
    MMin = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "," & NcasS - 1 & "))")
    MMax = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "," & NcasS + 1 & "))")
    If NewMin <> Worksheets(Foglio).Range("Q" & NcasS).Value Then GoTo NTcas
    If MMM >= Ws1.Range("R" & RR1).Value Then GoTo NTcas
    If RigaF - RigaI + 1 < Int(Ws2.Range("P" & Rows.Count).End(xlUp).Row / 2) Then
    If MMin = 1 Then GoTo NTcas
    If MMM <> 0 And MMax = 1 Then GoTo NTcas
    End If
    Ws2.Range("D" & NCas).Value = NcasS

For NC = 2 To Ws1.Cells(RR1, CC1).Value
Ncasuale2:
        If Evaluate("=Count((" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "))") = NumGS Then GoTo SaltaRR1
        NCas2 = Int(Rnd() * RigaF) + 1
        If NCas2 < RigaI Then GoTo Ncasuale2
        If Ws2.Range("D" & NCas2).Value <> "" Then GoTo Ncasuale2
        MyC = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D2:D" & UR2 & "," & NcasS & "))")
        If RR1 < VM + 1 Then
            If MyC = 5 - (VM - RR1) Then GoTo NTcas
        Else
            If MyC = 5 Then GoTo NTcas
        End If
        MMM = Evaluate("=SUM(COUNTIF(" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "," & NcasS & "))")
        If MMM >= Ws1.Cells(RR1, CC1).Value Then GoTo NTcas
        Ws2.Range("D" & NCas2).Value = NcasS
    Next NC
SaltaCC1:
Next NS
SaltaCC2:
    CC1 = 18
    GoTo NCasuale0
   If Evaluate("=Count((" & "'" & Foglio & "'" & "!D" & RigaI & ":D" & RigaF & "))") = NumGS Then GoTo Ncasuale
SaltaRR1:
Next RR1
AssRigAS
End Sub
Private Sub AssRigAS()
Set Ws1 = Worksheets("Riepilogo_Iscrizioni")
Set Ws2 = Worksheets(Foglio)
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
Randomize (Timer)
CSNR = Int(Rnd() * 2)
SepSett = Int((UR2 - 1) / 5) * 5
'------------

 
'------------
For RR2 = 2 To UR2
    LimiteS = Int(Int(SepSett / 5 + CSNR) / 2)
    Agg = 0
    ColInd = 1
    SCas = Ws2.Range("D" & RR2).Value
   ' Sett = "Sorteggio1"
    Set Wsx = Worksheets(Sett)
    Wsx.Select
    RIni = (SCas - Agg) * 6 - 5
Ncasuale3:
    NCas3 = Int(Rnd() * 5) + RIni + 1
    If NCas3 < RIni Then GoTo Ncasuale3
    If Wsx.Range("D" & NCas3).Value <> "" Then GoTo Ncasuale3
    Wsx.Range("A" & NCas3 & ":D" & NCas3).Interior.ColorIndex = ColInd
    Wsx.Range("A" & NCas3 & ":D" & NCas3).Font.ColorIndex = 2
    Wsx.Range("C" & NCas3).Value = Ws2.Range("B" & RR2).Value
    Wsx.Range("D" & NCas3).Value = Ws2.Range("C" & RR2).Value
    Application.Wait (Now + TimeValue("0:00:01"))
Next RR2

End Sub
Private Sub FormTab()
Set Wsx = Worksheets(Sett)
UR3 = Wsx.Range("C" & Rows.Count).End(xlUp).Row
ContaS = 0
For RR3 = 1 To UR3 Step 6
ContaS = ContaS + 1
Wsx.Range("A" & RR3).Value = "Settore " & ContaS
Wsx.Range("B" & RR3).Value = "Numero"
Wsx.Range("C" & RR3).Value = "Coppia"
Wsx.Range("D" & RR3).Value = "Società"
Range("A" & RR3 & ":D" & RR3).Interior.ColorIndex = 4
Next RR3
End Sub
Private Sub SortIni()
'macro sorteggio settori numerico
'Set ws3 = Worksheets(Sett)
Set Wsx = Worksheets(Sett)
Wsx.Columns("B:B").ClearContents
UR3 = Wsx.Range("C" & Rows.Count).End(xlUp).Row
For RR3 = 1 To UR3 Step 6
Wsx.Range("B" & RR3).Value = "Numero"
Next RR3

Randomize (Timer)
RipCas:
URX = Wsx.Range("C" & Rows.Count).End(xlUp).Row
NEff = URX - (URX / 6)
    NCS = Int(Rnd() * NEff) + 1
    NCSR = (Int(NCS / 5) + 1) * 6 - 4
    NCSR = NCSR Mod URX
    If NCSR = 0 Then NCSR = URX
        NumRig = 1
        Wsx.Range("B" & NCSR).Value = NumRig
        For RR1 = NCSR + 1 To NCSR + URX - 1
        ContR = RR1 Mod URX
        If ContR = 1 Then GoTo SaltaRRC
        If ContR = 0 Then ContR = URX
        If Wsx.Range("B" & ContR).Value <> "" Then GoTo SaltaRRC
        NumRig = NumRig + 1
        Wsx.Range("B" & ContR).Value = NumRig
SaltaRRC:
        Next RR1
End Sub

Avvia la macro "IniEstr"

Questa non effettua ancora il controllo se le coppie si ritrovano nello stesso settore di estrazioni precedenti
fammi sapere se, comunque, può andare bene così impostata

ciao

[Naus]

Ciao Flash30005,
innanzitutto grazie per il lavoro che stai facendo. Ho proceduto a seguire le tue istruzioni ma mi esce questo errore

[img=http://s30.postimg.org/44n1sojfx/errore.jpg]

[Flash30005]

Penso sia incompatibilità tra Excel 2010 e 2007 o precedente
commenta o sostituisci l'intero codice che hai evidenziato in giallo con questo

Codice: Seleziona tutto

   Columns("O:T").Sort Key1:=Range("P1"), Order1:=xlDescending

prova e fai sapere

ciao

P.s. sarò assente un paio di giorni, se invierai un feedback in serata potrei intervenire altrimenti dovrai attendere

[Naus]

Grazie Flash30005,
con la modifica non mi da più errore.

In questi giorni lo provo

[Flash30005]

Ok
ti dico subito che con quel numero di coppie (11 in una società e 7 in un'altra) non è possibile ottenere le combinazioni senza che almeno una coppia si incontri con un'altra pertanto dovrai accontentarti della macro inviata

ciao

[Naus]

Ciao Flash30005,
dopo svariate prove ti confermo (anche se già lo sapevi) che la macro funziona perfettamente.
Ti ringrazio per il tempo e la disponibilità che mi hai concesso