Novità

Numeri Random

80Sete

Advanced Member >PLATINUM PLUS<
Buona giornata a chi passerà da qui,(y) da poco esperto in materia,
dovrei formare dei cruciverba di 5x5.....7x7 di numeri Random
ma la serie dei numeri dovrei selezionarli io a piacimento,
e soprattutto non devono esserci dei doppi numeri, che siano come nello schema, tutti diversi.
1 - 2 - 3 - 4 - 5
6 - 7 - 8 - 9 - 10
11-12-13-14-15
16-17-18-19-20
21-22-23-24-25


ho creato inoltre una tabella in excel 5x5, con la formula =CASUALE.TRA(1;25)
ma ci sono sempre dei numeri Doppi, chiedo agli esperti, se c'è una formula in excel,
oppure uno script, dove inserisco (a scelta) 25 o 30 numeri,
che formino colonne da 5....da 6....da 7 numeri, dove nello script avrò la possibilità di scegliere
ogni volta quali e quanti numeri, e per quante colonne da ottenere,
tutto questo da utilizzare al Milion.Day-Vinci Casa- o Super Enalotto.
Ringrazio a chi potrà aiutarmi, ed evitare di fare i miei cruciverba a mano.
P.S. Forse, nel forum, esiste già uno script simile.
Ciao
 
Ciao 80Sete, io ho uno script per vincicasa (ma si può adattare ad altre lotterie) purtroppo ci possono essere numeri ripetuti.
Meglio che niente provalo.
metti almeno 12 numeri per uno schema 5x5

Codice:
'Option Explicit
Dim aNumUsati
Dim aColonne
Dim aNumScelti
Dim sFile,fin
sFile = GetDirectoryAppData & "Vincicasa.txt" 'allaccia archivio esterno
Call ApriBaseDatiFT(sFile,5,",",40)' tipo di lotteria con q.tà numeri e carattere separatore
Sub Main
   Dim nLato
   Dim r,c,k
   Dim n,es1
   Dim s
   Dim nTentativi
   Dim bTrovato
   Dim nScelti
   Dim bUnaPresenzaSola
   Const nMinLato = 2
   Const nMaxLato = 12
   Const nTentativiMax = 1000
   bUnaPresenzaSola = False
   fin = EstrazioniArchivioFT
   nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",6))
   If nLato < nMinLato Or nLato > nMaxLato Then
      MsgBox "Il lato dve essere compreso tra " & nMinLato & " e " & nMaxLato
      Exit Sub
   End If
   ReDim aNumScelti(0)
   nScelti = ScegliNumeri(aNumScelti)
   If nScelti >= nLato * nLato Then
      bUnaPresenzaSola = True
   End If
   Call DoEventsEx
   If nScelti <= nLato Then
      MsgBox "Selezionare piu numeri",vbInformation
      Exit Sub
   End If
   aNumUsati = ArrayNumeriToBool(aNumScelti)
   ReDim aDiagonali(nLato,nLato)
   Call CalcolaDiagonali(aDiagonali,nLato)
   Do While bTrovato = False
      ReDim aNumeri(nLato,nLato)
      For r = 1 To nLato
         For c = 1 To nLato
            n = ScegliNumero(r,c,aNumeri,nLato,aDiagonali,bUnaPresenzaSola)
            If n = 0 Then Exit For
            aNumeri(r,c) = n
         Next
         If n = 0 Then Exit For
      Next
      If colonneDuplicate(aNumeri,nLato,aDiagonali) = False Then
         bTrovato = True
      Else
         nTentativi = nTentativi + 1
         If nTentativi > nTentativiMax Then Exit Do
      End If
      If ScriptInterrotto Then Exit Do
      Call Messaggio("Cruciverba Generati " & nTentativi)
      DoEventsEx
   Loop
   For r = 1 To nLato
      ReDim aV(nLato)
      For c = 1 To nLato
         aV(c) = Format2(Int(aNumeri(r,c)))
      Next
      If r = 1 Then
         Call InitTabella(aV,,,6)
      Else
         Call AddRigaTabella(aV,,,6)
      End If
   Next
   If nTentativi > nTentativiMax Or colonneDuplicate(aNumeri,nLato,aDiagonali) Then
      Call Scrivi("ATTENZIONE CRUCIVERBA NON VALIDO",True,,,vbRed)
   End If
   Call Scrivi("Cruciverba " & nLato & "x" & nLato,True)
   Call Scrivi("Si vince con le righe , le colonne e le diagonali")
   Call Scrivi
   Call CreaTabella
   Call Scrivi
   Call Scrivi("Colonne in gioco",True)
   For k = 1 To UBound(aColonne)
      Call Scrivi(FormatSpace(k,5,True) & ") " & aColonne(k) & vbTab & es1)
   Next
   Call Scrivi
   Call Scrivi("Numeri usati",True)
   Call Scrivi(SpezzaStringaNumeri(GetNumRealmenteUsati(aNumeri,nLato)),,True)
   Call Scrivi
   Call ScriviTabellaFreq(aNumeri,nLato)
   Call SalvaFileColonne
End Sub
Sub CalcolaDiagonali(aDiagonali,nLato)
   Dim r,c
   For r = 1 To nLato
      c = c + 1
      aDiagonali(r,c) = True
   Next
   c = nLato + 1
   For r = 1 To nLato
      c = c - 1
      If aDiagonali(r,c) Then
         aDiagonali(r,c) = 1
      Else
         aDiagonali(r,c) = True
      End If
   Next
End Sub
Function ScegliNumero(Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
   Dim n
   Dim nPassaggi
   Do
      n = aNumScelti(NumeroCasuale(1,UBound(aNumScelti)))
      nPassaggi = nPassaggi + 1
      If nPassaggi > 1000 Then
         n = 0
         Exit Do
      End If
      If ScriptInterrotto Then
         n = 0
         Exit Do
      End If
      Call DoEventsEx
   Loop While NumeroNonValido(n,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
   ScegliNumero = n
End Function
Function NumeroNonValido(Numero,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
   Dim k,r,c
   If Numero = 0 Then
      NumeroNonValido = True
      Exit Function
   End If
   If bUnaVoltaSola Then
      For r = 1 To nLato
         For c = 1 To nLato
            If aNumeri(r,c) = Numero Then
               NumeroNonValido = True
               Exit Function
            End If
         Next
      Next
   End If
   If aNumUsati(Numero) = False Then
      NumeroNonValido = True
      Exit Function
   End If
   For k = 1 To nLato
      If aNumeri(Riga,k) = Numero Then
         NumeroNonValido = True
         Exit Function
      End If
   Next
   For k = 1 To nLato
      If aNumeri(k,Colonna) = Numero Then
         NumeroNonValido = True
         Exit Function
      End If
   Next
   If aDiagonali(Riga,Colonna) Then
      'If Riga = Colonna Or ((Riga = nLato/2)And (Colonna = nLato/2)) Then
      If Riga = Colonna Then
         c = Colonna + 1
         For r = Riga To 1 Step - 1
            c = c - 1
            If aNumeri(r,c) = Numero Then
               NumeroNonValido = True
               Exit Function
            End If
         Next
         c = Colonna - 1
         For r = Riga + 1 To nLato
            c = c + 1
            If aNumeri(r,c) = Numero Then
               NumeroNonValido = True
               Exit Function
            End If
         Next
      End If
      If Riga <> Colonna Or aDiagonali(Riga,Colonna) = 1 Then
         c = Colonna - 1
         For r = Riga To 1 Step - 1
            c = c + 1
            If aNumeri(r,c) = Numero Then
               NumeroNonValido = True
               Exit Function
            End If
         Next
         c = Colonna + 1
         For r = Riga + 1 To nLato
            c = c - 1
            If aNumeri(r,c) = Numero Then
               NumeroNonValido = True
               Exit Function
            End If
         Next
      End If
   End If
End Function
Function colonneDuplicate(aNumeri,nLato,aDiagonali)
   Dim nColonneTot
   Dim r,c,i
   Dim k,kk
   nColonneTot = nLato * 2 + 2
   ReDim aColonne(nColonneTot)
   For r = 1 To nLato
      ReDim aN(nLato)
      For c = 1 To nLato
         aN(c) = aNumeri(r,c)
      Next
      i = i + 1
      Call OrdinaMatrice(aN,1,1)
      aColonne(i) = StringaNumeri(aN,,True)
   Next
   For c = 1 To nLato
      ReDim aN(nLato)
      For r = 1 To nLato
         aN(r) = aNumeri(r,c)
      Next
      i = i + 1
      Call OrdinaMatrice(aN,1,1)
      aColonne(i) = StringaNumeri(aN,,True)
   Next
   ReDim aN(nLato)
   c = 0
   For r = 1 To nLato
      c = c + 1
      aN(r) = aNumeri(r,c)
   Next
   i = i + 1
   Call OrdinaMatrice(aN,1,1)
   aColonne(i) = StringaNumeri(aN,,True)
   ReDim aN(nLato)
   c = nLato + 1
   For r = 1 To nLato
      c = c - 1
      aN(r) = aNumeri(r,c)
   Next
   i = i + 1
   Call OrdinaMatrice(aN,1,1)
   aColonne(i) = StringaNumeri(aN,,True)
   For k = 1 To nColonneTot - 1
      For kk = k + 1 To nColonneTot
         If aColonne(k) = aColonne(kk) Then
            colonneDuplicate = True
            Exit Function
         End If
      Next
   Next
   For k = 1 To nColonneTot
      If Len(aColonne(k)) < nLato *2 +(nLato - 1) Then
         colonneDuplicate = True
         Exit Function
      End If
   Next
End Function
Function SpezzaStringaNumeri(sStringa)
   Dim k
   Dim s,i
   ReDim aV(0)
   Call SplitByChar(sStringa,".",aV)
   s = ""
   For k = 0 To UBound(aV)
      i = i + 1
      s = s & aV(k) & "."
      If i Mod 20 = 0 Then
         s = s & vbCrLf
      End If
   Next
   SpezzaStringaNumeri = Left(s,Len(s) - 1)
End Function
Function GetNumRealmenteUsati(aNumeri,nLato)
   Dim r,c,k
   Dim s
   ReDim aB(90)
   For r = 1 To nLato
      For c = 1 To nLato
         aB(aNumeri(r,c)) = True
      Next
   Next
   For k = 1 To 90
      If aB(k) Then
         s = s & Format2(k) & "."
      End If
   Next
   If s <> "" Then
      s = Left(s,Len(s) - 1)
   End If
   GetNumRealmenteUsati = s
End Function
Sub ScriviTabellaFreq(aNumeri,nLato)
   Dim r,c,k
   Dim s
   Dim nNumeriPoss
   nNumeriPoss = nLato * nLato
   ReDim aN(90,2)
   For r = 1 To 90
      aN(r,1) = r
   Next
   For r = 1 To nLato
      For c = 1 To nLato
         aN(aNumeri(r,c),2) = aN(aNumeri(r,c),2) + 1
      Next
   Next
   Call OrdinaMatrice(aN,- 1,2)
   ReDim aT(3)
   aT(1) = "Numero"
   aT(2) = "Presenze"
   aT(3) = " % "
   Call InitTabella(aT)
   For k = 1 To 90
      If aN(k,2) > 0 Then
         ReDim aV(3)
         aV(1) = aN(k,1)
         aV(2) = aN(k,2)
         aV(3) = Round((aN(k,2)*100)/nNumeriPoss,3) & " %"
         Call AddRigaTabella(aV)
      End If
   Next
   Call Scrivi("Presenze numeri in gioco nel cruciverba")
   Call CreaTabella
End Sub
Sub SalvaFileColonne
   Dim sFile
   Dim k
   sFile = GetDirectoryTemp & "Cruciverba.csv"
   If EliminaFile(sFile) Then
      For k = 1 To UBound(aColonne)
         Call ScriviFile(sFile,Replace(aColonne(k),".",";"),,False)
      Next
   End If
   Call Scrivi("Le colonne da giocare sono state salvate nel file : " & sFile)
End Sub
 
Grazie Mike58 x la celerità, questo va benissimo, ho fatto delle prove, spesso rilascia numeri doppi (come è logico) ma non è un problema....è capitato un paio di volte che siano tutti diversi, e poi in base a quello che serve....o aggiungo o elimino un numero a colonna. Comunque solo x curiosità....portare lo script a 7 numeri x colonna, è cosa rapida? Da ottobre seguo (saltuariamente) 10 e Lotto Serale, dove ho avuto diverse soddisfazioni giocando 7 nr. Ripeto, se è fattibile....altrimenti ne aggiungo uno a piacimento secondo le mie ricerche. Grazie1000 ancora.
Ciao
 
Cosa dire Mike? imbranataggine da parte mia :unsure: .....avevo provato prima, ma non mi accettava la modifica.
Ora ho riprovato, vai a capirne la causa.
ecco tutto a posto. Grazie e scusami x l'inconveniente.

7x7.jpgCiao
 

Ultima estrazione Lotto

  • Estrazione del lotto
    giovedì 10 luglio 2025
    Bari
    85
    25
    24
    62
    28
    Cagliari
    51
    07
    79
    73
    36
    Firenze
    80
    63
    59
    47
    05
    Genova
    26
    50
    73
    18
    76
    Milano
    86
    12
    75
    13
    68
    Napoli
    21
    46
    89
    28
    87
    Palermo
    84
    49
    44
    17
    10
    Roma
    50
    40
    68
    65
    82
    Torino
    29
    52
    02
    60
    65
    Venezia
    81
    21
    64
    01
    09
    Nazionale
    30
    56
    86
    68
    34
    Estrazione Simbolotto
    Nazionale
    29
    13
    42
    17
    07
Indietro
Alto