Login
Registrati
-
Articoli
-
Ops
Pardon Marius44
Mea colpa
albatros54 ti dispiace allegare il file con la macro non mi va
Ho modificato il codice postato in precedenza cosi:
For i = arr(1, 1) To arr(7, 1) n1 = i For j = arr(2, 1) To arr(8, 1) n2 = j For h = arr(3, 1) To arr(9, 1) n3 = h For k = arr(4, 1) To arr(10, 1) n4 = k For w = arr(5, 1) To arr(11, 1)Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Albatros è questa riga qui che da errore cosa ci devi mettere nel foglio2
arr = Foglio2.Range("g1").CurrentRegion.Value <<< AGGIUNTA
Buon pomeriggio a tutti
Non mi avete detto se quanto da me proposto risponde alla richiesta.
Non sono un "sistemista" e non capisco cosa intendete per "impostare la matrice"
Ciao,
Mario
inserisic i numeri (11) in questo caso , nella colonna G1 del foglio2 del file postato da Mario
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Si ma il problema è sempre lo stesso
le colonne del ridotto non le deve prendere dal pronostico , ma dalle colonne dello sviluppo!
Dal pronostico ci ero già riuscito anch'io
non ho capito, nel file postato da Mario lo sviluppo del ridotto(matrice)lo ha fatto su 11 numeri che vanno dal 1 all'11, quindi da quello che capisco io , i numeri che ha sviluppato, non sono altro che il pronostico , quindi sei io sostituisco il pronostico mettendo nella colonna G1 i numeri che voglio mettere in gioco, inseriti in ordine crescente e lancio il codice ho lo sviluppo del ridotto con i numeri che ho inserito.Se ho capito altrimenti cerca di essere piu chiaro.
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Ciao
Scusa Oscar ma nel tuo file al Foglio 1 vedo solo a destra Sistema integrale (che viene ricopiato in col.A) e poi sistema ridotto. Quale è il pronostico?
Teniamo presente che i numeri (come ha già fatto @albatros - ciao Gioacchino) possono essere inseriti a piacere, in una riga o in una colonna e poi (dalla riga o dalla colonna) impostare sia lo sviluppo completo (quello che potrebbe fare la mia macro fino alla stampa dei numeri in col. J:N) e poi in altra parte lo sviluppo ridotto.
Ciao,
Mario
Si albatros i numeri non li devo prendere ne da pronostico ne da Arrey
Li devo prendere solo dallo sviluppo integrale o condizionato che sia
Comunque ho risolto
Ringrazio tutti sono in debito lunedì faccio una donazione
un piccolo gesto per un grande forum
grazie ancora a tutti voi io da solo non ci sarei mai arrivato
Private Sub Riduzione() Numeri = Application.WorksheetFunction.CountA(Range("AA1:AZ1")) Range("J:N").ClearContents For i = 1 To Numeri For j = i + 1 To Numeri For h = j + 1 To Numeri For k = h + 1 To Numeri For w = k + 1 To Numeri x1 = x1 + 1 If i <> j And i <> h And i <> k And i <> w And _ j <> h And j <> k And j <> w And _ h <> k And h <> w And k <> w Then a = a + 1 Cells(a, 10) = Cells(x1, 1) Cells(a, 11) = Cells(x1, 2) Cells(a, 12) = Cells(x1, 3) Cells(a, 13) = Cells(x1, 4) Cells(a, 14) = Cells(x1, 5) 'controlla cifre appena inserite e 'conta se sono uguali alle precedenti 'se la conta è maggiore di 3 'cancella la riga appena inserita 'imposta il contatore riga a 1 in meno 'salta alla nuova riga uc = Cells(Rows.Count, 10).End(xlUp).Row If uc > 1 Then For p = 1 To uc - 1 conta = 0 For x = 10 To 14 If WorksheetFunction.CountIfs(Range("J" & p, "N" & p), Cells(a, x)) = 1 Then conta = conta + 1 Next x If conta > 3 Then Range("J" & a, "N" & a).ClearContents a = a - 1 Exit For End If Next p End If End If Next w Next k Next h Next j Next i End SubNon sono un "sistemista" e non capisco cosa intendete per "impostare la matrice
la matrice è lo sviluppo delle colonne del tuo codice.Quando tu hai una matrice puoi associare la matrice che hai sviluppato a qualsiasi pronostico, perchè ivalori della matrice vengono sostituiti dai valori del pronostico.
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )per curiosita potresti allega il file dove gira il tuo codice,Grazie
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Ciao
Scusa Oscar ma nel tuo file al Foglio 1 vedo solo a destra Sistema integrale (che viene ricopiato in col.A) e poi sistema ridotto. Quale è il pronostico?
Teniamo presente che i numeri (come ha già fatto @albatros - ciao Gioacchino) possono essere inseriti a piacere, in una riga o in una colonna e poi (dalla riga o dalla colonna) impostare sia lo sviluppo completo (quello che potrebbe fare la mia macro fino alla stampa dei numeri in col. J:N) e poi in altra parte lo sviluppo ridotto.
Ciao,
Mario
Ok Mario ti allego il foglio dove trovi lo sviluppo integrale il ridotto e il pronostico
Adesso che ho visto non era poi così difficile
Il principio era lo stesso che avevo fatto io a differenza che io mantenevo quelle minori di 4 dalla precedente , mentre tu hai
eliminato quelle maggiori di 3 dalla precedente
poi da quel 3 si decide il numero di riduzione
Ciao
Ho "abbellito" (si fa per dire
) l'elaborato. Aspetto critiche (spero poche) ed elogi (mi auguro molti).Ciao,
Mario
@oscar,
grazie per la tua generosa donazione! Non era dovuta ma è sempre apprezzatissima!
Ciao
Ciao
Ho "abbellito" (si fa per dire
) l'elaborato. Aspetto critiche (spero poche) ed elogi (mi auguro molti).Ciao,
Mario
A si bella , complimenti ,ma per mè così non è utlizzabile in quanto c'è l'ho in un programma che uso anche importa File , con la macro di riduzione separata ho la possibilità di ridurlo e stampare le schedine di sistemi ridotti
Una cosa utile che è un attimo , è mettere la selezione del ridotto tipo N1-N2-N3- ecc.
Io la utilizzo così come sotto con l'avvio dello sviluppo scelgo il tipo di riduzione o se lasciarlo condizionato e ridurlo dopo
`Application.ScreenUpdating = False With Sviluppo Rid = 4 - .ComboBox1.ListIndex End With Application.ScreenUpdating = False For Rig = 1 To Cells(Rows.Count, 1).End(xlUp).Row x1 = x1 + 1 Range("A" & Rig, "E" & Rig).Copy Cells(x1, 1) If x1 > 1 Then For p = 1 To x1 - 1 Conta = 0 For X = 1 To 5 If WorksheetFunction.CountIfs(Range("A" & p, "E" & p), Cells(x1, X)) = 1 Then Conta = Conta + 1 Next X If Conta > Rid Then x1 = x1 - 1 Exit For End If Next p End If Next Range("A" & 1 + x1, "E" & Rig).ClearContents With Sviluppo .Label9 = " " & Format(Application.WorksheetFunction.CountA(Range("A:A")), "#,0") End With Application.ScreenUpdating = True End Sub`se lasciarlo condizionato
nel tuo codice non vedo nessuna condizione che lo sviluppo delle colonne intero deve far, o forse ho capito male io.
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Le condizioni sono in un'altra macro
Se al sistema hai applicato delle condizioni si attiva il quadro condizioni tipo colonne filtro paralleli simmetrie somme distanze ecc.ecc.
ma questo avviene dopo lo sviluppo integrale , dove verifica tutte le colonne , mantenendo solo quelle che rispettano le condizioni , alla fine di questo calcolo , se hai applicato il ridotto , verifica di nuovo il sistema condizionato mantenendo a condizioni rispettate la garanzia del ridotto
ma tutto questo è parecchio complesso
adesso la copio poi la incollo
Le condizioni sono in un'altra macro
ora si, perchè mi mancava questo passaggio
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )Questa è quella del totocalcio , non è applicabile in quello sviluppo li e una struttura diversa , ma la funzione è sempre la stessa
per quello sviluppo li non ho ancora creato nessuna condizione , perchè lo sto facendo adesso
Sub Applica_Condizioni() Application.ScreenUpdating = False With Sviluppo Esci = .Esci End With With Calcio If .ComboBox1.ListIndex = 0 Then Classe = 3 If .ComboBox1.ListIndex = 1 Then Classe = 4 If .ComboBox1.ListIndex = 2 Then Classe = 5 If .ComboBox1.ListIndex = 3 Then Classe = 7 If .ComboBox1.ListIndex = 4 Then Classe = 8 If .ComboBox1.ListIndex = 5 Then Classe = 9 End With CFiltri = WorksheetFunction.CountA(Foglio2.Range("A22:XFD22")) Colon = WorksheetFunction.CountA(Foglio4.Range("A:A")) X = 0 Conta = 1 For Col = 2 To Colon X = X + 1 Cons1 = 0 consx = 0 cons2 = 0 Consecutivi1 = 0 Consecutivix = 0 Consecutivi2 = 0 In1 = 0 Inx = 0 In2 = 0 Inter1 = 0 Interx = 0 Inter2 = 0 Dist1 = 0 Distx = 0 Dist2 = 0 Distanza1 = 0 Distanzax = 0 Distanza2 = 0 Cont1 = 0: Fulcro1 = 0: Contx = 0: Fulcrox = 0: Cont2 = 0: Fulcro2 = 0 Fin1 = 0 Finx = 0 Fin2 = 0 TotFin = 0 Rem--------------------------------------------------Colonne Filtro Filtro = 0 Tot = 0 If Foglio6.Range("B25") = False Then GoTo UscitaFiltri For f = 1 To CFiltri ' Filtri Foglio2 For ix = 2 To 21 '9 'k - 1 'Var ' Numero Partite Foglio1 If Foglio2.Cells(ix, f) <> "" Then If Foglio2.Cells(ix, f) = Foglio4.Cells(Col, ix) Then Filtro = Filtro + 1 End If End If Next If Filtro = Foglio2.Cells(22, f) Or Filtro = Foglio2.Cells(23, f) Or Filtro = Foglio2.Cells(24, f) Or Filtro = Foglio2.Cells(25, f) Or Filtro = Foglio2.Cells(26, f) _ Or Filtro = Foglio2.Cells(27, f) Or Filtro = Foglio2.Cells(28, f) Or Filtro = Foglio2.Cells(29, f) Or Filtro = Foglio2.Cells(30, f) Or Filtro = Foglio2.Cells(31, f) _ Or Filtro = Foglio2.Cells(32, f) Or Filtro = Foglio2.Cells(33, f) Or Filtro = Foglio2.Cells(34, f) Or Filtro = Foglio2.Cells(35, f) Then Tot = Tot + 1 Filtro = 0 End If Next If Tot = CFiltri Then UscitaFiltri: Rem------------------------------------------Condizioni For I = 2 To Classe Rem------------------------------------------Consecutivi If Foglio6.Range("B4") = False Then GoTo UscitaConsecutiviA If Foglio4.Cells(Col, I) = 1 Then If I = Classe Then GoTo 1 If Foglio4.Cells(Col, I) = Foglio4.Cells(Col, 1 + I) Then Consecutivi1 = Consecutivix1 + 1 1: End If If Foglio4.Cells(Col, I) = "X" Then If I = Classe Then GoTo X If Foglio4.Cells(Col, I) = Foglio4.Cells(Col, 1 + I) Then Consecutivix = Consecutivix + 1 X: End If If Foglio4.Cells(Col, I) = 2 Then If I = Classe Then GoTo 2 If Foglio4.Cells(Col, I) = Foglio4.Cells(Col, 1 + I) Then Consecutivi2 = Consecutivix2 + 1 2: End If UscitaConsecutiviA: Rem---------------------------------------Interruzioni If Foglio4.Cells(Col, I) = 1 Then If Foglio4.Cells(Col, 1 + I) <> 1 Then In1 = In1 + 1 End If End If If In1 > 0 Then Inter1 = In1 - 1 If Foglio4.Cells(Col, I) = "X" Then If Foglio4.Cells(Col, 1 + I) <> "X" Then Inx = Inx + 1 End If End If If Inx > 0 Then Interx = Inx - 1 If Foglio4.Cells(Col, I) = 2 Then If Foglio4.Cells(Col, 1 + I) <> 2 Then In2 = In2 + 1 End If End If If In2 > 0 Then Inter2 = In2 - 1 Rem---------------------------------------------------Distanza If Foglio4.Cells(Col, I) <> 1 Then Dist1 = Dist1 + 1 Else Dist1 = 0 If Dist1 > Distanza1 Then Distanza1 = Dist1 End If If Foglio4.Cells(Col, I) <> "X" Then Distx = Distx + 1 Else Distx = 0 If Distx > Distanzax Then Distanzax = Distx End If If Foglio4.Cells(Col, I) <> 2 Then Dist2 = Dist2 + 1 Else Dist2 = 0 If Dist2 > Distanza2 Then Distanza2 = Dist2 End If Rem---------------------------------------------------------------------------------Dispari Dispari1 = 0 Disparix = 0 Dispari2 = 0 For Yi = 2 To Classe Step 2 If Foglio4.Cells(Col, Yi) = 1 Then Dispari1 = Dispari1 + 1 If Foglio4.Cells(Col, Yi) = "X" Then Disparix = Disparix + 1 If Foglio4.Cells(Col, Yi) = 2 Then Dispari2 = Dispari2 + 1 Next Rem-----------------------------------Fulcro If Foglio4.Cells(Col, I) = 1 Then Cont1 = Cont1 + 1: Fulcro1 = Fulcro1 + I - 1 If Foglio4.Cells(Col, I) = "X" Then Contx = Contx + 1: Fulcrox = Fulcrox + I - 1 If Foglio4.Cells(Col, I) = 2 Then Cont2 = Cont2 + 1: Fulcro2 = Fulcro2 + I - 1 Rem------------------Finali 1 X 2 If Foglio4.Cells(Col, I) = 1 Then Fin1 = Fin1 + I - 1 If Foglio4.Cells(Col, I) = "X" Then Finx = Finx + I - 1 If Foglio4.Cells(Col, I) = 2 Then Fin2 = Fin2 + I - 1 Next TotConsecutivi = Consecutivi1 + Consecutivix + Consecutivi2 TotInterr = Inter1 + Interx + Inter2 TotDist = Distanza1 + Distanzax + Distanza2 TotDispari = Dispari1 + Disparix + Dispari2 If Cont1 > 0 Then Ful1 = Int(Fulcro1 / Cont1) Else Ful1 = 0 If Contx > 0 Then Fulx = Int(Fulcrox / Contx) Else Fulx = 0 If Cont2 > 0 Then Ful2 = Int(Fulcro2 / Cont2) Else Ful2 = 0 TotFulc = Ful1 + Fulx + Ful2 If Fin1 > 9 Then Fin1 = Right(Fin1, 1) * 1 If Finx > 9 Then Finx = Right(Finx, 1) * 1 If Fin2 > 9 Then Fin2 = Right(Fin2, 1) * 1 TotFin = Fin1 + Finx + Fin2 Rem--------------------------------------------Consecutivi If Foglio6.Range("B4") = False Then GoTo UscitaConsecutivi If WorksheetFunction.CountIfs(Foglio6.Range("C1:J1"), "X") = 8 Then GoTo SaltaConsecutivi1 If Consecutivi1 = Foglio6.Cells(1, 3) Or Consecutivi1 = Foglio6.Cells(1, 4) Or Consecutivi1 = Foglio6.Cells(1, 5) Or Consecutivi1 = Foglio6.Cells(1, 6) Or Consecutivi1 = Foglio6.Cells(1, 7) _ Or Consecutivi1 = Foglio6.Cells(1, 8) Or Consecutivi1 = Foglio6.Cells(1, 9) Or Consecutivi1 = Foglio6.Cells(1, 10) Then SaltaConsecutivi1: If WorksheetFunction.CountIfs(Foglio6.Range("C2:J2"), "X") = 8 Then GoTo SaltaConsecutivix If Consecutivix = Foglio6.Cells(2, 3) Or Consecutivix = Foglio6.Cells(2, 4) Or Consecutivix = Foglio6.Cells(2, 5) Or Consecutivix = Foglio6.Cells(2, 6) Or Consecutivix = Foglio6.Cells(2, 7) _ Or Consecutivix = Foglio6.Cells(2, 8) Or Consecutivix = Foglio6.Cells(2, 9) Or Consecutivix = Foglio6.Cells(2, 10) Then SaltaConsecutivix: If WorksheetFunction.CountIfs(Foglio6.Range("C3:J3"), "X") = 8 Then GoTo SaltaConsecutivi2 If Consecutivi2 = Foglio6.Cells(3, 3) Or Consecutivi2 = Foglio6.Cells(3, 4) Or Consecutivi2 = Foglio6.Cells(3, 5) Or Consecutivi2 = Foglio6.Cells(3, 6) Or Consecutivi2 = Foglio6.Cells(3, 7) _ Or Consecutivi2 = Foglio6.Cells(3, 8) Or Consecutivi2 = Foglio6.Cells(3, 9) Or Consecutivi2 = Foglio6.Cells(3, 10) Then SaltaConsecutivi2: If WorksheetFunction.CountIfs(Foglio6.Range("C4:J4"), "X") = 8 Then GoTo TotaleConsecutivi If TotConsecutivi = Foglio6.Cells(4, 3) Or TotConsecutivi = Foglio6.Cells(4, 4) Or TotConsecutivi = Foglio6.Cells(4, 5) Or TotConsecutivi = Foglio6.Cells(4, 6) Or TotConsecutivi = Foglio6.Cells(4, 7) _ Or TotConsecutivi = Foglio6.Cells(4, 8) Or TotConsecutivi = Foglio6.Cells(4, 9) Or TotConsecutivi = Foglio6.Cells(4, 10) Then TotaleConsecutivi: UscitaConsecutivi: Rem--------------------------------------------Interruzioni1 If Foglio6.Range("B8") = False Then GoTo UscitaInterruzioni If WorksheetFunction.CountIfs(Foglio6.Range("C5:J5"), "X") = 8 Then GoTo SaltaInterruzioni1 If Inter1 = Foglio6.Cells(5, 3) Or Inter1 = Foglio6.Cells(5, 4) Or Inter1 = Foglio6.Cells(5, 5) Or Inter1 = Foglio6.Cells(5, 6) Or Inter1 = Foglio6.Cells(5, 7) _ Or Inter1 = Foglio6.Cells(5, 8) Or Inter1 = Foglio6.Cells(5, 9) Or Inter1 = Foglio6.Cells(5, 10) Then SaltaInterruzioni1: If WorksheetFunction.CountIfs(Foglio6.Range("C6:J6"), "X") = 8 Then GoTo SaltaInterruzioniX If Interx = Foglio6.Cells(6, 3) Or Interx = Foglio6.Cells(6, 4) Or Interx = Foglio6.Cells(6, 5) Or Interx = Foglio6.Cells(6, 6) Or Interx = Foglio6.Cells(6, 7) _ Or Interx = Foglio6.Cells(6, 8) Or Interx = Foglio6.Cells(6, 9) Or Interx = Foglio6.Cells(6, 10) Then SaltaInterruzioniX: If WorksheetFunction.CountIfs(Foglio6.Range("C7:J7"), "X") = 8 Then GoTo SaltaInterruzioni2 If Inter2 = Foglio6.Cells(7, 3) Or Inter2 = Foglio6.Cells(7, 4) Or Inter2 = Foglio6.Cells(7, 5) Or Inter2 = Foglio6.Cells(7, 6) Or Inter2 = Foglio6.Cells(7, 7) _ Or Inter2 = Foglio6.Cells(7, 8) Or Inter2 = Foglio6.Cells(7, 9) Or Inter2 = Foglio6.Cells(7, 10) Then SaltaInterruzioni2: If WorksheetFunction.CountIfs(Foglio6.Range("C8:J8"), "X") = 8 Then GoTo TotInterruzioni If TotInterr = Foglio6.Cells(8, 3) Or TotInterr = Foglio6.Cells(8, 4) Or TotInterr = Foglio6.Cells(8, 5) Or TotInterr = Foglio6.Cells(8, 6) Or TotInterr = Foglio6.Cells(8, 7) _ Or TotInterr = Foglio6.Cells(8, 8) Or TotInterr = Foglio6.Cells(8, 9) Or TotInterr = Foglio6.Cells(8, 10) Then TotInterruzioni: UscitaInterruzioni: Rem--------------------------------------------Distanza1 If Foglio6.Range("B12") = False Then GoTo SaltaUscitaDistanza If WorksheetFunction.CountIfs(Foglio6.Range("C9:K9"), "X") = 9 Then GoTo SaltaDistanza1 If Distanza1 = Foglio6.Cells(9, 3) Or Distanza1 = Foglio6.Cells(9, 4) Or Distanza1 = Foglio6.Cells(9, 5) Or Distanza1 = Foglio6.Cells(9, 6) Or Distanza1 = Foglio6.Cells(9, 7) _ Or Distanza1 = Foglio6.Cells(9, 8) Or Distanza1 = Foglio6.Cells(9, 9) Or Distanza1 = Foglio6.Cells(9, 10) Or Distanza1 = Foglio6.Cells(9, 11) Then SaltaDistanza1: Rem--------------------------------------------Distanzax If WorksheetFunction.CountIfs(Foglio6.Range("C10:K10"), "X") = 9 Then GoTo SaltaDistanzax If Distanzax = Foglio6.Cells(10, 3) Or Distanzax = Foglio6.Cells(10, 4) Or Distanzax = Foglio6.Cells(10, 5) Or Distanzax = Foglio6.Cells(10, 6) Or Distanzax = Foglio6.Cells(10, 7) _ Or Distanzax = Foglio6.Cells(10, 8) Or Distanzax = Foglio6.Cells(10, 9) Or Distanzax = Foglio6.Cells(10, 10) Or Distanzax = Foglio6.Cells(10, 11) Then SaltaDistanzax: Rem--------------------------------------------Distanza2 If WorksheetFunction.CountIfs(Foglio6.Range("C11:K11"), "X") = 9 Then GoTo SaltaDistanza2 If Distanza2 = Foglio6.Cells(11, 3) Or Distanza2 = Foglio6.Cells(11, 4) Or Distanza2 = Foglio6.Cells(11, 5) Or Distanza2 = Foglio6.Cells(11, 6) Or Distanza2 = Foglio6.Cells(11, 7) _ Or Distanza2 = Foglio6.Cells(11, 8) Or Distanza2 = Foglio6.Cells(11, 9) Or Distanza2 = Foglio6.Cells(11, 10) Or Distanza2 = Foglio6.Cells(11, 11) Then SaltaDistanza2: Rem--------------------------------------------Totale Distanza If WorksheetFunction.CountIfs(Foglio6.Range("C12:N12"), "X") = 12 Then GoTo UscitaTotaleDistanza If TotDist = Foglio6.Cells(12, 3) Or TotDist = Foglio6.Cells(12, 4) Or TotDist = Foglio6.Cells(12, 5) Or TotDist = Foglio6.Cells(12, 6) Or TotDist = Foglio6.Cells(12, 7) _ Or TotDist = Foglio6.Cells(12, 8) Or TotDist = Foglio6.Cells(12, 9) Or TotDist = Foglio6.Cells(12, 10) Or TotDist = Foglio6.Cells(12, 11) Or TotDist = Foglio6.Cells(12, 12) _ Or TotDist = Foglio6.Cells(12, 13) Or TotDist = Foglio6.Cells(12, 14) Then UscitaTotaleDistanza: SaltaUscitaDistanza: Rem--------------------------------------------Dispari1 If Foglio6.Range("B16") = False Then GoTo SaltaUscitaDispari If WorksheetFunction.CountIfs(Foglio6.Range("C13:J13"), "X") = 8 Then GoTo SaltaDispari1 If Dispari1 = Foglio6.Cells(13, 3) Or Dispari1 = Foglio6.Cells(13, 4) Or Dispari1 = Foglio6.Cells(13, 5) Or Dispari1 = Foglio6.Cells(13, 6) Or Dispari1 = Foglio6.Cells(13, 7) _ Or Dispari1 = Foglio6.Cells(13, 8) Or Dispari1 = Foglio6.Cells(13, 9) Or Dispari1 = Foglio6.Cells(13, 10) Then SaltaDispari1: Rem--------------------------------------------Disparix If WorksheetFunction.CountIfs(Foglio6.Range("C14:J14"), "X") = 8 Then GoTo SaltaDisparix If Disparix = Foglio6.Cells(14, 3) Or Disparix = Foglio6.Cells(14, 4) Or Disparix = Foglio6.Cells(14, 5) Or Disparix = Foglio6.Cells(14, 6) Or Disparix = Foglio6.Cells(14, 7) _ Or Disparix = Foglio6.Cells(14, 8) Or Disparix = Foglio6.Cells(14, 9) Or Disparix = Foglio6.Cells(14, 10) Then SaltaDisparix: Rem--------------------------------------------Dispari2 If WorksheetFunction.CountIfs(Foglio6.Range("C15:J15"), "X") = 8 Then GoTo SaltaDispari2 If Dispari2 = Foglio6.Cells(15, 3) Or Dispari2 = Foglio6.Cells(15, 4) Or Dispari2 = Foglio6.Cells(15, 5) Or Dispari2 = Foglio6.Cells(15, 6) Or Dispari2 = Foglio6.Cells(15, 7) _ Or Dispari2 = Foglio6.Cells(15, 8) Or Dispari2 = Foglio6.Cells(15, 9) Or Dispari2 = Foglio6.Cells(15, 10) Then SaltaDispari2: Rem--------------------------------------------Totale Dispari If WorksheetFunction.CountIfs(Foglio6.Range("C16:J16"), "X") = 8 Then GoTo SaltaTotDispari If TotDispari = Foglio6.Cells(16, 3) Or TotDispari = Foglio6.Cells(16, 4) Or TotDispari = Foglio6.Cells(16, 5) Or TotDispari = Foglio6.Cells(16, 6) Or TotDispari = Foglio6.Cells(16, 7) _ Or TotDispari = Foglio6.Cells(16, 8) Or TotDispari = Foglio6.Cells(16, 9) Or TotDispari = Foglio6.Cells(16, 10) Then SaltaTotDispari: SaltaUscitaDispari: Rem--------------------------------------------Fulcro1 If Foglio6.Range("B20") = False Then GoTo SaltaUscitaFulcro If WorksheetFunction.CountIfs(Foglio6.Range("C17:L17"), "X") = 10 Then GoTo SaltaFul1 If Ful1 = Foglio6.Cells(17, 3) Or Ful1 = Foglio6.Cells(17, 4) Or Ful1 = Foglio6.Cells(17, 5) Or Ful1 = Foglio6.Cells(17, 6) Or Ful1 = Foglio6.Cells(17, 7) _ Or Ful1 = Foglio6.Cells(17, 8) Or Ful1 = Foglio6.Cells(17, 9) Or Ful1 = Foglio6.Cells(17, 10) Or Ful1 = Foglio6.Cells(17, 11) Or Ful1 = Foglio6.Cells(17, 12) Then SaltaFul1: Rem--------------------------------------------Fulcrox If WorksheetFunction.CountIfs(Foglio6.Range("C18:L18"), "X") = 10 Then GoTo SaltaFulx If Fulx = Foglio6.Cells(18, 3) Or Fulx = Foglio6.Cells(18, 4) Or Fulx = Foglio6.Cells(18, 5) Or Fulx = Foglio6.Cells(18, 6) Or Fulx = Foglio6.Cells(18, 7) _ Or Fulx = Foglio6.Cells(18, 8) Or Fulx = Foglio6.Cells(18, 9) Or Fulx = Foglio6.Cells(18, 10) Or Fulx = Foglio6.Cells(18, 11) Or Fulx = Foglio6.Cells(18, 12) Then SaltaFulx: Rem--------------------------------------------Fulcro2 If WorksheetFunction.CountIfs(Foglio6.Range("C19:L19"), "X") = 10 Then GoTo SaltaFul2 If Ful2 = Foglio6.Cells(19, 3) Or Ful2 = Foglio6.Cells(19, 4) Or Ful2 = Foglio6.Cells(19, 5) Or Ful2 = Foglio6.Cells(19, 6) Or Ful2 = Foglio6.Cells(19, 7) _ Or Ful2 = Foglio6.Cells(19, 8) Or Ful2 = Foglio6.Cells(19, 9) Or Ful2 = Foglio6.Cells(19, 10) Or Ful2 = Foglio6.Cells(19, 11) Or Ful2 = Foglio6.Cells(19, 12) Then SaltaFul2: Rem------------------Fulcro Totale If WorksheetFunction.CountIfs(Foglio6.Range("C20:Q20"), "X") = 15 Then GoTo SaltaFulcroTot If TotFulc = Foglio6.Cells(20, 3) Or TotFin = Foglio6.Cells(20, 4) Or TotFulc = Foglio6.Cells(20, 5) Or TotFulc = Foglio6.Cells(20, 6) Or TotFulc = Foglio6.Cells(20, 7) _ Or TotFulc = Foglio6.Cells(20, 8) Or TotFulc = Foglio6.Cells(20, 9) Or TotFulc = Foglio6.Cells(20, 10) Or TotFulc = Foglio6.Cells(20, 11) Or TotFulc = Foglio6.Cells(20, 12) _ Or TotFulc = Foglio6.Cells(20, 13) Or TotFulc = Foglio6.Cells(20, 14) Or TotFulc = Foglio6.Cells(20, 15) Or TotFulc = Foglio6.Cells(20, 16) Or TotFulc = Foglio6.Cells(20, 17) Then SaltaFulcroTot: SaltaUscitaFulcro: Rem------------------Finali 1 If Foglio6.Range("B24") = False Then GoTo SaltaUscita If WorksheetFunction.CountIfs(Foglio6.Range("C21:L21"), "X") = 10 Then GoTo SaltaFin1 If Fin1 = Foglio6.Cells(21, 3) Or Fin1 = Foglio6.Cells(21, 4) Or Fin1 = Foglio6.Cells(21, 5) Or Fin1 = Foglio6.Cells(21, 6) Or Fin1 = Foglio6.Cells(21, 7) _ Or Fin1 = Foglio6.Cells(21, 8) Or Fin1 = Foglio6.Cells(21, 9) Or Fin1 = Foglio6.Cells(21, 10) Or Fin1 = Foglio6.Cells(21, 11) Or Fin1 = Foglio6.Cells(21, 12) Then SaltaFin1: Rem------------------Finali X If WorksheetFunction.CountIfs(Foglio6.Range("C22:L22"), "X") = 10 Then GoTo SaltaFinx If Finx = Foglio6.Cells(22, 3) Or Finx = Foglio6.Cells(22, 4) Or Finx = Foglio6.Cells(22, 5) Or Finx = Foglio6.Cells(22, 6) Or Finx = Foglio6.Cells(22, 7) _ Or Finx = Foglio6.Cells(22, 8) Or Finx = Foglio6.Cells(22, 9) Or Finx = Foglio6.Cells(22, 10) Or Finx = Foglio6.Cells(22, 11) Or Finx = Foglio6.Cells(22, 12) Then SaltaFinx: Rem------------------Finali 2 If WorksheetFunction.CountIfs(Foglio6.Range("C23:L23"), "X") = 10 Then GoTo SaltaFin2 If Fin2 = Foglio6.Cells(23, 3) Or Fin2 = Foglio6.Cells(23, 4) Or Fin2 = Foglio6.Cells(23, 5) Or Fin2 = Foglio6.Cells(23, 6) Or Fin2 = Foglio6.Cells(23, 7) _ Or Fin2 = Foglio6.Cells(23, 8) Or Fin2 = Foglio6.Cells(23, 9) Or Fin2 = Foglio6.Cells(23, 10) Or Fin2 = Foglio6.Cells(23, 11) Or Fin2 = Foglio6.Cells(23, 12) Then SaltaFin2: Rem------------------Finali Totale If WorksheetFunction.CountIfs(Foglio6.Range("C24:E24"), "X") = 3 Then GoTo SaltaFinTot If TotFin = Foglio6.Cells(24, 3) Or TotFin = Foglio6.Cells(24, 4) Or TotFin = Foglio6.Cells(24, 5) Then SaltaFinTot: SaltaUscita: Conta = Conta + 1 Foglio4.Range("B" & Col & ":U" & Col).Copy Foglio4.Cells(Conta, 2) End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If End If Rig = WorksheetFunction.CountA(Foglio4.Range("A:A")) - 1 With Sviluppo DoEvents .Label7 = " " & X .Label5.BackColor = &HFF0000 .Label5.Width = X / Rig * 258 .Label9 = " " & Conta - 1 If Esci = 1 Then .Label5.Width = 0: .Label7 = "": .Label9 = "": Foglio4.[A2:U10000] = "" End With If Esci = 1 Then GoTo Fine Next Range(Foglio4.Cells(Conta + 1, 1), Foglio4.Cells(Colon + 1, 21)) = "" Fine: With Calcio .Label200 = " File: " & .Nuovo1 & " Integrale Col. " & .Col & " Ridotto Col. " & Format(WorksheetFunction.CountA(Foglio4.Range("A:A")) - 1, "#,0") .Label582 = "Colonne Iniziali " & Format(.Col, "#,0") & " Colonne Finali " & Format(WorksheetFunction.CountA(Foglio4.Range("A:A")) - 1, "#,0") End With End SubQuesta è per il MilionDay
ma si applica sol al suo programma dove esistono tutti i quadri delle condizioni
Questa è piu facile del totocalcio , perchè questa ha solo dei numeri a differenza del totocalcio che ha 2 numeri e una lettera (1-2-x)
`'-------------------------------------------4 Fisse If FISSE = 4 Then Application.ScreenUpdating = False [A:F] = "" Col = Label5 For I = 1 To Label5 For F = 1 To FISSE Foglio1.Cells(I, F) = Foglio1.Cells(2, 26 + F) Next Foglio1.Cells(I, 5) = Foglio1.Cells(1, 26 + I) Range("A" & I, "E" & I).Sort Key1:=Range("A" & I), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight Label6 = I DoEvents Label3.Width = I / Col * 216 Next If WorksheetFunction.CountIf(Foglio8.Range("B2:B94"), "TRUE") > 0 Then GoTo Annulla4 With Home .Label111 = I - 1 .Label111 = Format(.Label111, "#,0") End With Annulla4: Application.ScreenUpdating = True If WorksheetFunction.CountIf(Foglio8.Range("B2:B94"), "TRUE") > 0 Then Condizioni Rid = "" Unload Me End If '-------------------------------------------------------------------- If FISSE = 5 Then [A:F] = "" For I = 1 To 5 Foglio1.Cells(1, I) = Foglio1.Cells(2, 26 + I) Next Label6 = 1 If WorksheetFunction.CountIf(Foglio8.Range("B2:B94"), "TRUE") > 0 Then GoTo Annulla5 With Home .Label111 = 1 .Label111 = Format(.Label111, "#,0") End With Annulla5: Application.ScreenUpdating = True If WorksheetFunction.CountIf(Foglio8.Range("B2:B94"), "TRUE") > 0 Then Condizioni Rid = "" Unload Me End If End Sub Rem---------------------------INIZIO CONDIZIONI Private Sub Condizioni() Application.ScreenUpdating = False Rem---------------------------------------------------------------------PULISCO TUTTO Range("CV:EO") = "" '------------------------------------------------NUMERO DI COLONNE DA CANCELLARE Label8.Visible = True Label35.Visible = True Label36.Visible = True Colon = WorksheetFunction.CountA(Foglio1.Range("A:A")) Label10 = "Colonnne filtrate N.... " & "0" Dim Sriga, Riga, Nriga As Integer Dim NPari, Somma As Variant Ritm = 0 ritmax = 0 '''''''''''''''''''''''''''''''''''''''''''' Foglio2.Range("A2:O10000") = "" Riga = 1 'riga iniziale Sriga = 0 While Foglio1.Cells(Riga, 1) <> "" 'fino a che la cella, numero Riga, colonna 1 (la A) è diversa da vuota, quindi occupata Label7.Width = (Riga / Colon) * 216 DoEvents Condi_Attive = 46 '<<---------------------------NUMERO DI CONDIZIONI ATTIVE Rem-------------------------------------------------------------Presenza Pari NPari = 0 NDispari = 0 For X = 1 To 5 If Foglio1.Cells(Riga, X) Mod 2 = 0 Then NPari = NPari + 1 Else NDispari = NDispari + 1 End If Next If Foglio8.Range("B2") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B2") <> False Then If NPari = Foglio8.Cells(2, 3) Or NPari = Foglio8.Cells(2, 4) Or NPari = Foglio8.Cells(2, 5) Or NPari = Foglio8.Cells(2, 6) Or NPari = Foglio8.Cells(2, 7) Or NPari = Foglio8.Cells(2, 8) Then Cells(Riga, 100) = 1 End If End If Rem-------------------------------------------------------------Presenza Dispari If Foglio8.Range("B4") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B4") <> False Then If NDispari = Foglio8.Cells(4, 3) Or NDispari = Foglio8.Cells(4, 4) Or NDispari = Foglio8.Cells(4, 5) Or NDispari = Foglio8.Cells(4, 6) Or NDispari = Foglio8.Cells(4, 7) Or NDispari = Foglio8.Cells(4, 8) Then Cells(Riga, 101) = 1 End If End If Rem-------------------------------------------------------------Cosecutivi Pari & Dispari CPari = 0 CDispari = 0 CPar = 0 CDis = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then CPar = CPar + 1 CDis = 0 Else CPar = 0 CDis = CDis + 1 End If If CPar > CPari Then CPari = CPar End If If CDis > CDispari Then CDispari = CDis End If Next If Foglio8.Range("B3") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B3") <> False Then If CPari = Foglio8.Cells(3, 3) Or CPari = Foglio8.Cells(3, 4) Or CPari = Foglio8.Cells(3, 5) Or CPari = Foglio8.Cells(3, 6) Or CPari = Foglio8.Cells(3, 7) Or CPari = Foglio8.Cells(3, 8) Then Cells(Riga, 102) = 1 End If End If If Foglio8.Range("B5") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B5") <> False Then If CDispari = Foglio8.Cells(5, 3) Or CDispari = Foglio8.Cells(5, 4) Or CDispari = Foglio8.Cells(5, 5) Or CDispari = Foglio8.Cells(5, 6) Or CDispari = Foglio8.Cells(5, 7) Or CDispari = Foglio8.Cells(5, 8) Then Cells(Riga, 103) = 1 End If End If Rem----------------------------------------------Consecutività Numerica If Foglio8.Range("B6") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B6") <> False Then Dim CNumerica As Integer Conta = 1 CNumerica = 0 For Y = 1 To 4 If Foglio1.Cells(Riga, Y) = (Foglio1.Cells(Riga, 1 + Y) - 1) Then Conta = Conta + 1 Else Conta = 1 End If If Conta > CNumerica Then CNumerica = Conta End If Next If CNumerica = Foglio8.Cells(6, 4) Or CNumerica = Foglio8.Cells(6, 5) Or CNumerica = Foglio8.Cells(6, 6) Or CNumerica = Foglio8.Cells(6, 7) Or CNumerica = Foglio8.Cells(6, 8) Then Cells(Riga, 104) = 1 End If End If If Foglio8.Range("B7") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B7") <> False Then Rem----------------------------------------------------Interruzioni Conta = 0 Interruzion = 0 For Y = 1 To 4 If Foglio1.Cells(Riga, Y) <> (Foglio1.Cells(Riga, 1 + Y) - 1) Then Conta = Conta + 1 End If If Conta > Interruzion Then Interruzion = Conta End If Next If Interruzion = Foglio8.Cells(7, 3) Or Interruzion = Foglio8.Cells(7, 4) Or Interruzion = Foglio8.Cells(7, 5) Or Interruzion = Foglio8.Cells(7, 6) Or Interruzion = Foglio8.Cells(7, 7) Then Cells(Riga, 105) = 1 End If End If If Foglio8.Range("B8") = False Then Condi_Attive = Condi_Attive - 10 If Foglio8.Range("B8") <> False Then Rem-------------------------------------------Cadenza 0 Cad0 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 0 Then Cad0 = Cad0 + 1 End If Next If Cad0 = Foglio8.Cells(8, 3) Or Cad0 = Foglio8.Cells(8, 4) Or Cad0 = Foglio8.Cells(8, 5) Or Cad0 = Foglio8.Cells(8, 6) Or Cad0 = Foglio8.Cells(8, 7) Or Cad0 = Foglio8.Cells(8, 8) Then Cells(Riga, 106) = 1 End If Rem-------------------------------------------Cadenza 1 Cad1 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 1 Then Cad1 = Cad1 + 1 End If Next If Cad1 = Foglio8.Cells(9, 3) Or Cad1 = Foglio8.Cells(9, 4) Or Cad1 = Foglio8.Cells(9, 5) Or Cad1 = Foglio8.Cells(9, 6) Or Cad1 = Foglio8.Cells(9, 7) Or Cad1 = Foglio8.Cells(9, 8) Then Cells(Riga, 107) = 1 End If Rem-------------------------------------------Cadenza 2 Cad2 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 2 Then Cad2 = Cad2 + 1 End If Next If Cad2 = Foglio8.Cells(10, 3) Or Cad2 = Foglio8.Cells(10, 4) Or Cad2 = Foglio8.Cells(10, 5) Or Cad2 = Foglio8.Cells(10, 6) Or Cad2 = Foglio8.Cells(10, 7) Or Cad2 = Foglio8.Cells(10, 8) Then Cells(Riga, 108) = 1 End If Rem-------------------------------------------Cadenza 3 Cad3 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 3 Then Cad3 = Cad3 + 1 End If Next If Cad3 = Foglio8.Cells(11, 3) Or Cad3 = Foglio8.Cells(11, 4) Or Cad3 = Foglio8.Cells(11, 5) Or Cad3 = Foglio8.Cells(11, 6) Or Cad3 = Foglio8.Cells(11, 7) Or Cad3 = Foglio8.Cells(11, 8) Then Cells(Riga, 109) = 1 End If Rem-------------------------------------------Cadenza 4 Cad4 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 4 Then Cad4 = Cad4 + 1 End If Next If Cad4 = Foglio8.Cells(12, 3) Or Cad4 = Foglio8.Cells(12, 4) Or Cad4 = Foglio8.Cells(12, 5) Or Cad4 = Foglio8.Cells(12, 6) Or Cad4 = Foglio8.Cells(12, 7) Or Cad4 = Foglio8.Cells(12, 8) Then Cells(Riga, 110) = 1 End If Rem-------------------------------------------Cadenza 5 Cad5 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 5 Then Cad5 = Cad5 + 1 End If Next If Cad5 = Foglio8.Cells(13, 3) Or Cad5 = Foglio8.Cells(13, 4) Or Cad5 = Foglio8.Cells(13, 5) Or Cad5 = Foglio8.Cells(13, 6) Or Cad5 = Foglio8.Cells(13, 7) Or Cad5 = Foglio8.Cells(13, 8) Then Cells(Riga, 111) = 1 End If Rem-------------------------------------------Cadenza 6 Cad6 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 6 Then Cad6 = Cad6 + 1 End If Next If Cad6 = Foglio8.Cells(14, 3) Or Cad6 = Foglio8.Cells(14, 4) Or Cad6 = Foglio8.Cells(14, 5) Or Cad6 = Foglio8.Cells(14, 6) Or Cad6 = Foglio8.Cells(14, 7) Or Cad6 = Foglio8.Cells(14, 8) Then Cells(Riga, 112) = 1 End If Rem-------------------------------------------Cadenza 7 Cad7 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 7 Then Cad7 = Cad7 + 1 End If Next If Cad7 = Foglio8.Cells(15, 3) Or Cad7 = Foglio8.Cells(15, 4) Or Cad7 = Foglio8.Cells(15, 5) Or Cad7 = Foglio8.Cells(15, 6) Or Cad7 = Foglio8.Cells(15, 7) Or Cad7 = Foglio8.Cells(15, 8) Then Cells(Riga, 113) = 1 End If Rem-------------------------------------------Cadenza 8 Cad8 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 8 Then Cad8 = Cad8 + 1 End If Next If Cad8 = Foglio8.Cells(16, 3) Or Cad8 = Foglio8.Cells(16, 4) Or Cad8 = Foglio8.Cells(16, 5) Or Cad8 = Foglio8.Cells(16, 6) Or Cad8 = Foglio8.Cells(16, 7) Or Cad8 = Foglio8.Cells(16, 8) Then Cells(Riga, 114) = 1 End If Rem-------------------------------------------Cadenza 9 Cad9 = 0 For Y = 1 To 5 If Right(Foglio1.Cells(Riga, Y), 1) = 9 Then Cad9 = Cad9 + 1 End If Next If Cad9 = Foglio8.Cells(17, 3) Or Cad9 = Foglio8.Cells(17, 4) Or Cad9 = Foglio8.Cells(17, 5) Or Cad9 = Foglio8.Cells(17, 6) Or Cad9 = Foglio8.Cells(17, 7) Or Cad9 = Foglio8.Cells(17, 8) Then Cells(Riga, 115) = 1 End If End If If Foglio8.Range("B18") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B18") <> False Then Rem--------------------------------------------Cadenze Consecutive CadC = 0 For Y = 1 To 4 If Right(Foglio1.Cells(Riga, Y), 1) = Right(Foglio1.Cells(Riga, 1 + Y), 1) Then CadC = CadC + 1 End If Next If CadC = Foglio8.Cells(18, 3) Or CadC = Foglio8.Cells(18, 4) Or CadC = Foglio8.Cells(18, 5) Or CadC = Foglio8.Cells(18, 6) Or CadC = Foglio8.Cells(18, 7) Then Cells(Riga, 116) = 1 End If End If Rem-------------------------------------------Simmetrie If Foglio8.Range("B19") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B19") <> False Then Sim = 0 If Foglio1.Cells(Riga, 1) + Foglio1.Cells(Riga, 5) = 56 Then Sim = Sim + 1 If Foglio1.Cells(Riga, 2) + Foglio1.Cells(Riga, 4) = 56 Then Sim = Sim + 1 If Sim = Foglio8.Cells(19, 3) Or Sim = Foglio8.Cells(19, 4) Or Sim = Foglio8.Cells(19, 5) Then Cells(Riga, 117) = 1 End If End If Rem-------------------------------------------Paralleli If Foglio8.Range("B20") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B20") <> False Then Par = 0 If Foglio1.Cells(Riga, 4) - Foglio1.Cells(Riga, 1) = 27 Then Par = Par + 1 If Foglio1.Cells(Riga, 5) - Foglio1.Cells(Riga, 2) = 27 Then Par = Par + 1 If Par = Foglio8.Cells(20, 3) Or Par = Foglio8.Cells(20, 4) Or Par = Foglio8.Cells(20, 5) Then Cells(Riga, 118) = 1 End If End If Rem--------------------------------------------------------------------------Specchi If Foglio8.Range("B21") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B21") <> False Then Spec = 0 For Y = 1 To 4 If Right(Foglio1.Cells(Riga, Y), 1) = Left(Foglio1.Cells(Riga, 1 + Y), 1) Then Spec = Spec + 1 End If Next If Spec = Foglio8.Cells(21, 3) Or Spec = Foglio8.Cells(21, 4) Or Spec = Foglio8.Cells(21, 5) Or Spec = Foglio8.Cells(21, 6) Or Spec = Foglio8.Cells(21, 7) Then Cells(Riga, 119) = 1 End If End If Rem---------------------------------------------------------Fulcro If Foglio8.Range("B22") = False Then Condi_Attive = Condi_Attive - 3 If Foglio8.Range("B22") <> False Then Dim Pari, Dispari, FULP, FULD, Find, FindP As Integer ContaP = 0 ContaD = 0 FULP = 0 FULD = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then ContaP = ContaP + 1 FULP = FULP + Y Else ContaD = ContaD + 1 FULD = FULD + Y End If If ContaP > 0 Then Pari = Int(FULP / ContaP) Else Pari = 0 End If If ContaD > 0 Then Dispari = Int(FULD / ContaD) Else Dispari = 0 End If TotFul = Pari + Dispari Next If Pari = Foglio8.Cells(22, 3) Or Pari = Foglio8.Cells(22, 4) Or Pari = Foglio8.Cells(22, 5) Or Pari = Foglio8.Cells(22, 6) Or Pari = Foglio8.Cells(22, 7) Or Pari = Foglio8.Cells(22, 8) Then Cells(Riga, 120) = 1 End If If Dispari = Foglio8.Cells(23, 3) Or Dispari = Foglio8.Cells(23, 4) Or Dispari = Foglio8.Cells(23, 5) Or Dispari = Foglio8.Cells(23, 6) Or Dispari = Foglio8.Cells(23, 7) Or Dispari = Foglio8.Cells(23, 8) Then Cells(Riga, 121) = 1 End If If TotFul = Foglio8.Cells(24, 3) Or TotFul = Foglio8.Cells(24, 4) Or TotFul = Foglio8.Cells(24, 5) Or TotFul = Foglio8.Cells(24, 6) Or TotFul = Foglio8.Cells(24, 7) Then Cells(Riga, 122) = 1 End If End If If Foglio8.Range("B25") = False Then Condi_Attive = Condi_Attive - 3 If Foglio8.Range("B25") <> False Then Rem-----------------------------------------------------Finali/Pari FinPari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then FinPari = FinPari + Y End If Next If FinPari > 9 Then FinPari = FinPari - 10 If FinPari = Foglio8.Cells(25, 3) Or FinPari = Foglio8.Cells(25, 4) Or FinPari = Foglio8.Cells(25, 5) Or FinPari = Foglio8.Cells(25, 6) Or FinPari = Foglio8.Cells(25, 7) Or FinPari = Foglio8.Cells(25, 8) Or FinPari = Foglio8.Cells(25, 10) Or FinPari = Foglio8.Cells(25, 11) Or FinPari = Foglio8.Cells(25, 12) Or FinPari = Foglio8.Cells(25, 13) Then Cells(Riga, 123) = 1 End If Rem-----------------------------------------------------Finali/Dispari FinDisp = 0 For DS = 1 To 5 If Foglio1.Cells(Riga, DS) Mod 2 <> 0 Then FinDisp = FinDisp + DS End If Next If FinDisp > 9 Then FinDisp = FinDisp - 10 If FinDisp = Foglio8.Cells(26, 3) Or FinDisp = Foglio8.Cells(26, 4) Or FinDisp = Foglio8.Cells(26, 5) Or FinDisp = Foglio8.Cells(26, 6) Or FinDisp = Foglio8.Cells(26, 7) Or FinDisp = Foglio8.Cells(26, 8) Or FinDisp = Foglio8.Cells(26, 10) Or FinDisp = Foglio8.Cells(26, 11) Or FinDisp = Foglio8.Cells(26, 12) Or FinDisp = Foglio8.Cells(26, 13) Then Cells(Riga, 124) = 1 End If Rem------------------------------------------------------Finali totale TotFin = FinPari + FinDisp If TotFin = Foglio8.Cells(27, 4) Then Cells(Riga, 125) = 1 End If End If Rem------------------------------------------------------Simmetrie Dirette PD If Foglio8.Range("B28") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B28") <> False Then SimDiretta = 0 If Foglio1.Cells(Riga, 1) Mod 2 = 0 Then If Foglio1.Cells(Riga, 5) Mod 2 = 0 Then SimDiretta = SimDiretta + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 0 Then If Foglio1.Cells(Riga, 4) Mod 2 = 0 Then SimDiretta = SimDiretta + 1 End If End If If Foglio1.Cells(Riga, 1) Mod 2 = 1 Then If Foglio1.Cells(Riga, 5) Mod 2 = 1 Then SimDiretta = SimDiretta + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 1 Then If Foglio1.Cells(Riga, 4) Mod 2 = 1 Then SimDiretta = SimDiretta + 1 End If End If If SimDiretta = Foglio8.Cells(28, 3) Or SimDiretta = Foglio8.Cells(28, 4) Or SimDiretta = Foglio8.Cells(28, 5) Then Cells(Riga, 126) = 1 End If End If Rem------------------------------------------------------Simmetrie Inversa PD If Foglio8.Range("B29") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B29") <> False Then SimInversa = 0 If Foglio1.Cells(Riga, 1) Mod 2 = 1 Then If Foglio1.Cells(Riga, 3) Mod 2 = 1 Then SimInversa = SimInversa + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 1 Then If Foglio1.Cells(Riga, 4) Mod 2 = 1 Then SimInversa = SimInversa + 1 End If End If If Foglio1.Cells(Riga, 1) Mod 2 = 0 Then If Foglio1.Cells(Riga, 3) Mod 2 = 0 Then SimInversa = SimInversa + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 0 Then If Foglio1.Cells(Riga, 4) Mod 2 = 0 Then ' SimInversa = SimInversa + 1 End If End If If SimInversa = Foglio8.Cells(29, 3) Or SimInversa = Foglio8.Cells(29, 4) Or SimInversa = Foglio8.Cells(29, 5) Then Cells(Riga, 127) = 1 End If End If Rem------------------------------------------------------Paralleli Diretti PD If Foglio8.Range("B30") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B30") <> False Then ParDiretti = 0 If Foglio1.Cells(Riga, 1) Mod 2 = 0 Then If Foglio1.Cells(Riga, 4) Mod 2 = 0 Then ParDiretti = ParDiretti + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 0 Then If Foglio1.Cells(Riga, 5) Mod 2 = 0 Then ParDiretti = ParDiretti + 1 End If End If If Foglio1.Cells(Riga, 1) Mod 2 = 1 Then If Foglio1.Cells(Riga, 4) Mod 2 = 1 Then ParDiretti = ParDiretti + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 1 Then If Foglio1.Cells(Riga, 5) Mod 2 = 1 Then ParDiretti = ParDiretti + 1 End If End If If ParDiretti = Foglio8.Cells(30, 3) Or ParDiretti = Foglio8.Cells(30, 4) Or ParDiretti = Foglio8.Cells(30, 5) Then Cells(Riga, 128) = 1 End If End If Rem------------------------------------------------------Paralleli Inversi PD If Foglio8.Range("B31") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B31") <> False Then ParInversi = 0 If Foglio1.Cells(Riga, 2) Mod 2 = 1 Then If Foglio1.Cells(Riga, 3) Mod 2 = 1 Then ParInversi = ParInversi + 1 End If End If If Foglio1.Cells(Riga, 3) Mod 2 = 1 Then If Foglio1.Cells(Riga, 4) Mod 2 = 1 Then ParInversi = ParInversi + 1 End If End If If Foglio1.Cells(Riga, 2) Mod 2 = 0 Then If Foglio1.Cells(Riga, 3) Mod 2 = 0 Then ParInversi = ParInversi + 1 End If End If If Foglio1.Cells(Riga, 3) Mod 2 = 0 Then If Foglio1.Cells(Riga, 4) Mod 2 = 0 Then ' ParInversi = ParInversi + 1 End If End If If ParInversi = Foglio8.Cells(31, 3) Or ParInversi = Foglio8.Cells(31, 4) Or ParInversi = Foglio8.Cells(31, 5) Then Cells(Riga, 129) = 1 End If End If Rem----------------------------------------------------Distanza Minima If Foglio8.Range("B33") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B33") <> False Then Distm = 50 For Y = 1 To 4 Conta = Foglio1.Cells(Riga, 1 + Y) - Foglio1.Cells(Riga, Y) If Distm > Conta Then Distm = Conta Next If Distm >= Foglio8.Cells(33, 3) And Distm <= Foglio8.Cells(33, 4) Then Cells(Riga, 130) = 1 End If End If Rem----------------------------------------------------Distanza Media If Foglio8.Range("B34") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B34") <> False Then Uno = Foglio1.Cells(Riga, 2) - Foglio1.Cells(Riga, 1) Due = Foglio1.Cells(Riga, 3) - Foglio1.Cells(Riga, 2) Tre = Foglio1.Cells(Riga, 4) - Foglio1.Cells(Riga, 3) Quattro = Foglio1.Cells(Riga, 5) - Foglio1.Cells(Riga, 4) DistMedia = Int(WorksheetFunction.Sum(Uno + Due + Tre + Quattro) / 4) If DistMedia >= Foglio8.Cells(34, 3) And DistMedia <= Foglio8.Cells(34, 4) Then Cells(Riga, 131) = 1 End If End If Rem----------------------------------------------------Distanza Massima If Foglio8.Range("B35") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B35") <> False Then DistMax = 0 For Y = 1 To 4 Conta = Foglio1.Cells(Riga, 1 + Y) - Foglio1.Cells(Riga, Y) If DistMax < Conta Then DistMax = Conta Next If DistMax >= Foglio8.Cells(35, 3) And DistMax <= Foglio8.Cells(35, 4) Then Cells(Riga, 132) = 1 End If End If Rem----------------------------------------------------Distanza Totale If Foglio8.Range("B36") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B36") <> False Then DistTot = WorksheetFunction.Sum(Distm + DistMedia + DistMax) If DistTot >= Foglio8.Cells(36, 3) And DistTot <= Foglio8.Cells(36, 4) Then Cells(Riga, 133) = 1 End If End If Rem--------------------------------------------------------------------------------Somma Pari If Foglio8.Range("B37") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B37") <> False Then SPari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then Conta = Conta + 1 SPari = SPari + Foglio1.Cells(Riga, Y) End If Next If SPari >= Foglio8.Cells(37, 3) And SPari <= Foglio8.Cells(37, 4) Then Cells(Riga, 134) = 1 End If End If Rem----------------------------------------------------------------------------------Media pari If Foglio8.Range("B38") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B38") <> False Then Conta = 0 MPari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then Conta = Conta + 1 MPari = MPari + Foglio1.Cells(Riga, Y) End If Next If MPari > 0 Then MPari = Int(MPari / Conta) Else MPari = 0 If MPari >= Foglio8.Cells(38, 3) And MPari <= Foglio8.Cells(38, 4) Then Cells(Riga, 135) = 1 End If End If Rem--------------------------------------------------------------------------------Somma Dispari If Foglio8.Range("B39") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B39") <> False Then SDispari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 <> 0 Then Conta = Conta + 1 SDispari = SDispari + Foglio1.Cells(Riga, Y) End If Next If SDispari >= Foglio8.Cells(39, 3) And SDispari <= Foglio8.Cells(39, 4) Then Cells(Riga, 136) = 1 End If End If Rem----------------------------------------------------------------------------------Media Dispari If Foglio8.Range("B40") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B40") <> False Then Conta = 0 MDispari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 <> 0 Then Conta = Conta + 1 MDispari = MDispari + Foglio1.Cells(Riga, Y) End If Next If MDispari > 0 Then MDispari = Int(MDispari / Conta) Else MDispari = 0 If MDispari >= Foglio8.Cells(40, 3) And MDispari <= Foglio8.Cells(40, 4) Then Cells(Riga, 137) = 1 End If End If Rem----------------------------------------------------Totale Somme If Foglio8.Range("B41") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B41") <> False Then TotSomme = WorksheetFunction.Sum(SPari + MPari + SDispari + MDispari) If TotSomme >= Foglio8.Cells(41, 3) And TotSomme <= Foglio8.Cells(41, 4) Then Cells(Riga, 138) = 1 End If End If Rem----------------------------------------------------Somma Globale If Foglio8.Range("B42") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B42") <> False Then SommaGlobale = Application.WorksheetFunction.Sum(Range(Foglio1.Cells(Riga, 1), Foglio1.Cells(Riga, 5))) If SommaGlobale >= Foglio8.Cells(42, 3) And SommaGlobale <= Foglio8.Cells(42, 4) Then Cells(Riga, 139) = 1 End If End If Rem----------------------------------------------------Distanza Minima SPECIALI-1 If Foglio8.Range("B87") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B87") <> False Then SPDistm = 50 For Y = 1 To 4 Conta = Foglio1.Cells(Riga, 1 + Y) - Foglio1.Cells(Riga, Y) If SPDistm > Conta Then SPDistm = Conta Next If Foglio8.Range("D87") = "D" Then If Right(SPDistm, 1) Mod 2 <> 0 Then Cells(Riga, 143) = 1 End If End If If Foglio8.Range("D87") = "P" Then If Right(SPDistm, 1) Mod 2 = 0 Then Cells(Riga, 143) = 1 End If End If End If Rem----------------------------------------------------Distanza Media SPECIALI-1 If Foglio8.Range("B88") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B88") <> False Then Uno = Foglio1.Cells(Riga, 2) - Foglio1.Cells(Riga, 1) Due = Foglio1.Cells(Riga, 3) - Foglio1.Cells(Riga, 2) Tre = Foglio1.Cells(Riga, 4) - Foglio1.Cells(Riga, 3) Quattro = Foglio1.Cells(Riga, 5) - Foglio1.Cells(Riga, 4) DistMedia = Int(WorksheetFunction.Sum(Uno + Due + Tre + Quattro) / 4) If Foglio8.Range("D88") = "D" Then If Right(DistMedia, 1) Mod 2 <> 0 Then Cells(Riga, 144) = 1 End If End If If Foglio8.Range("D88") = "P" Then If Right(DistMedia, 1) Mod 2 = 0 Then Cells(Riga, 144) = 1 End If End If End If Rem----------------------------------------------------Distanza Massima SPECIALI-1 If Foglio8.Range("B89") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B89") <> False Then DistMax = 0 For Y = 1 To 4 Conta = Foglio1.Cells(Riga, 1 + Y) - Foglio1.Cells(Riga, Y) If DistMax < Conta Then DistMax = Conta Next If Foglio8.Range("D89") = "D" Then If Right(DistMax, 1) Mod 2 <> 0 Then Cells(Riga, 145) = 1 End If End If If Foglio8.Range("D89") = "P" Then If Right(DistMax, 1) Mod 2 = 0 Then Cells(Riga, 145) = 1 End If End If End If Rem----------------------------------------------------------------------------------Media PARI-SPECIALI1 2 If Foglio8.Range("B91") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B91") <> False Then Conta = 0 MDispari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 = 0 Then Conta = Conta + 1 MDispari = MDispari + Foglio1.Cells(Riga, Y) End If Next If MDispari > 0 Then MDispari = Int(MDispari / Conta) Else MDispari = 0 If Foglio8.Range("D91") = "D" Then If Right(MDispari, 1) Mod 2 <> 0 Then Cells(Riga, 140) = 1 End If End If If Foglio8.Range("D91") = "P" Then If Right(MDispari, 1) Mod 2 = 0 Then Cells(Riga, 140) = 1 End If End If End If Rem--------------------------------------------------------------------------------Somma Dispari SPECIALI 2 If Foglio8.Range("B92") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B92") <> False Then SDispari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 <> 0 Then Conta = Conta + 1 SDispari = SDispari + Foglio1.Cells(Riga, Y) End If Next If Foglio8.Range("D92") = "D" Then If Right(SDispari, 1) Mod 2 <> 0 Then Cells(Riga, 141) = 1 End If End If If Foglio8.Range("D92") = "P" Then If Right(SDispari, 1) Mod 2 = 0 Then Cells(Riga, 141) = 1 End If End If End If Rem----------------------------------------------------------------------------------Media DISPARI-SPECIALI1 2 If Foglio8.Range("B93") = False Then Condi_Attive = Condi_Attive - 1 If Foglio8.Range("B93") <> False Then Conta = 0 MDDispari = 0 For Y = 1 To 5 If Foglio1.Cells(Riga, Y) Mod 2 <> 0 Then Conta = Conta + 1 MDDispari = MDDispari + Foglio1.Cells(Riga, Y) End If Next If MDDispari > 0 Then MDDispari = Int(MDDispari / Conta) Else MDDispari = 0 If Foglio8.Range("D93") = "D" Then If Right(MDDispari, 1) Mod 2 <> 0 Then Cells(Riga, 142) = 1 End If End If If Foglio8.Range("D93") = "P" Then If Right(MDDispari, 1) Mod 2 = 0 Then Cells(Riga, 142) = 1 End If End If End If Rem---------------------------------------------------------FINE CONDIZIONI Zero: Ritm = Ritm + 1 ' <----------------------------------------------Conto i Ritardi Massimi If WorksheetFunction.Sum(Foglio1.Range("CV" & Riga, "EO" & Riga)) = Condi_Attive Then Rem---------------------------------------------------------------------Ritardo Massimo If Ritm >= ritmax Then ritmax = Ritm Ritm = 0 Else ritmax = ritmax End If With Home .Label177 = ritmax End With Rem -------------------------------------------------------Scrivo la Colonna Sriga = Sriga + 1 For I = 1 To 5 Foglio1.Cells(Sriga, I) = Foglio1.Cells(Riga, I) Label36 = " " & Sriga Label36 = Format(Label36, "#,0") Next End If Annulla: Riga = Riga + 1 Pari = 0 Somma = 0 Wend Foglio1.Range("A" & Sriga + 1, "E" & 500000) = "" 'Elimino le colonne scartate With Home .Label111 = Sriga .Label111 = Format(.Label111, "#,0") End With Application.ScreenUpdating = True Unload Me End Sub`
Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )B'hè adesso perchè la vedi così , ma si parte piano piano
ad esempio prendiamo la somma da 70 a 120 sviluppato il sistema si inizia a calcolare la somma della prima riga e si scende fino a quando trovi una colonna che soddisfa la condizione , a questo punto la copi nella prima riga poi si va avanti fino alla prossima che si copia nella seconda riga utilizzando un contatore +1 ad ogni riga che soddisfa la condizione , a fine controllo da contatore +1 elimini tutte le colonne fino alla fine , così ti rimane solo quelle che hanno rispettato la condizione
