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