[Risolto] Macro per inserimento ed aggiornamento dati gioco del Lotto

[arckborg]

Mi presento: sono nuovo di questo Forum (anche se non nego che periodicamente vengo a consultare i Vs. sempre utili consigli), sono un architetto di "lungo corso" che ancora esercita la libera professione ma che, nel poco tempo libero che gli resta, si diletta a realizzare dei semplici templates divulgativi con L.O. Calc.

Ma veniamo a noi: la presente per chiedere la Vs. cortese quanto sapiente collaborazione al fine di realizzare n. 1 macro, articolata in piu' subroutine, per questo file "PrimeNumberSystem" da me realizzato (con LibreOffice Calc), a solo titolo di passatempo, relativo alla valutazione di una metodologia (basata sui numeri primi) per il gioco del Lotto.

Per meglio spiegare nel dettaglio cosa dovrebbe eseguire la suddetta macro, anziché perdermi in un mare di parole, con il rischio poi di non essermi spiegato bene, ho preferito inviarVi il tutto via Dropbox - sia il file di Calc (particolarmente pesante) che le le relative richieste/spiegazioni mediante alcuni semplici screenshot alquanto esplicativi.

- La versione di Libre Office che attualmente uso e’ la 7.3.5.2 (per Mac)
- Sistema operativo: MAC OS High Sierra v. 10.13.6
- installato su di un MacBook Pro (15” – 2011) con processore da 2,2 GHz INTEL Core i7.

[charlie]

Ciao e benvenuto sul forum.

L’utente che apre un quesito si impegna:

• a seguirlo dando riscontro quanto prima alle risposte ricevute nel giro di qualche giorno;
  - inserire il [Risolto] e la ✔ verde come previsto;
• rispettare le altre regole implicite del forum ( Istruzioni per nuovi arrivati ).

In caso di inosservanza saremo costretti ad azioni di “richiamo”, sospensione o chiusura del profilo utente.

Buon proseguimento.

[arckborg]

OK ! Messaggio ricevuto e ben recepito. Grazie.

[charlie]

La cartella inserita in dropbox risulta vuota. E non sono scaricabili i file precedentemente inviati alla mail "amministrazione del forum" (dove non dovevano essere mandati).

[arckborg]

Provero' ad inviarveli di nuovo su Dropbox. Scusatemi per gli inconvenienti occorsimi.

[Gaetanopr]

Se funziona vogliamo una % sulle vincite

Codice: Seleziona tutto

Sub Insert
Dim Doc As Object
Dim Sh As Object

Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Pronostico")
Dati = Sh.GetCellRangeByName("AB5:AG14").GetDataArray
DataEstrazione = Sh.GetCellRangeByName("W2").Value

For i = 0 To Ubound(Dati)
   Ruota = Doc.Sheets.GetByName(Dati(i)(0))
   c = Ruota.createCursor
   c.gotoEndOfUsedArea(false) 
   LastRow = c.RangeAddress.EndRow
   For n = LastRow To 5 Step - 1 
       If Ruota.GetCellByPosition(1, n).String <> "" Then  LastRow = n : exit for
   Next n
   For x = 1 To 5 
        If Ruota.GetCellByPosition(1+x, LastRow).Value = DataEstrazione Then MsgBox ("Estrazione per la ruota " & Ruota & " già inserita", 64, "INSERT") : exit For
        Ruota.GetCellByPosition(2+x, LastRow+1).Value = Dati(i)(x)
        Ruota.GetCellRangeByName("P5").FormulaLocal = "=SE(D6=0 O(MAX(B6:B" & LastRow+2 & ")<=45);""–"";MAX(B6:B" & LastRow+2 & ")-45+5)"
        Ruota.GetCellRangeByName("Q4").FormulaLocal= "=SE(CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1)<=1;"""";CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1))"
        Rng = Ruota.getCellRangeByName("Q4:AN4")
        Rng.fillAuto(com.sun.star.sheet.FillDirection.TO_RIGHT, 1)
   Next x
Next i
End Sub


Sub Reset1()
beep

If MsgBox("Sei sicuro di voler resettare tutte le estrazioni ???", 64+4, "RESET")  = 6 Then
   Doc = ThisComponent
   Sh = Doc.Sheets.GetByName("Pronostico")
   Sh.GetCellRangeByName("AC5:AG14").ClearContents(1)
   Cell = Sh.getCellRangeByName("AC5")
   ThisComponent.CurrentController.Select(Cell) 
End If
End Sub

la verifica dell'inserimento avviene soltanto con il precedente, con una modifica si può confrontare con tutte le estrazioni inserite.

[arckborg]

Grazie infinite Gaetanopr. La macro che hai compilato e' quasi perfetta, mancano ancora solo 2 piccole correzioni: a) aggiungere un MsgBox "Sei sicuro di voler inserire i nuovi estratti nelle rispettive Ruote, SI, NO"; b) inserire una formula di controllo, con relativo MsgBox che avverta l'utente che non puo' inserire i dati in quanto "ATTENZIONE !!! Nel tabellone non sono stati ancora inseriti tutti gli estratti delle 10 Ruote, OK".
Per quanto riguarda invece le mie possibili vincite, tuttavia, di devo dare una brutta notizia dato che io non giochero' mai, la mia e' una semplice curiosita'; come ben sai in questi tipi di gioco non puo' esistere alcuna strategia/metodologia vincente.

[Gaetanopr]

Si si infatti Il mio se funziona era riferito alla macro come compilazione dati e non come strategia di vincita, pure io come te non ci gioco.
Prova adesso

Codice: Seleziona tutto

Sub Insert
Dim Doc As Object
Dim Sh As Object
If MsgBox("Sei sicuro di voler inserire i nuovi estratti nelle rispettive Ruote ???", 64+4, "INSERT")  = 7 Then EXIT SUB
Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Pronostico")
Range = Sh.getCellRangeByName("AB5:AG14")
oRangeVuota = Range.queryEmptyCells.RangeAddresses
if UBound(oRangeVuota)>= 0 then 
   MsgBox("ATTENZIONE !!! Nel tabellone non sono stati ancora inseriti tutti gli estratti delle 10 Ruote", 16, "INSERT") 
   EXIT SUB
End If   
Dati = Range.GetDataArray
DataEstrazione = Sh.GetCellRangeByName("W2").Value

For i = 0 To Ubound(Dati)
   Ruota = Doc.Sheets.GetByName(Dati(i)(0))
   c = Ruota.createCursor
   c.gotoEndOfUsedArea(false) 
   LastRow = c.RangeAddress.EndRow
   For n = LastRow To 5 Step - 1 
       If Ruota.GetCellByPosition(1, n).String <> "" Then  LastRow = n : exit for
   Next n
   For x = 1 To 5 
        If Ruota.GetCellByPosition(1+x, LastRow).Value = DataEstrazione Then MsgBox ("Estrazione per la ruota " & Ruota & " già inserita", 64, "INSERT") : exit For
        Ruota.GetCellByPosition(2+x, LastRow+1).Value = Dati(i)(x)
        Ruota.GetCellRangeByName("P5").FormulaLocal = "=SE(D6=0 O(MAX(B6:B" & LastRow+2 & ")<=45);""–"";MAX(B6:B" & LastRow+2 & ")-45+5)"
        Ruota.GetCellRangeByName("Q4").FormulaLocal= "=SE(CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1)<=1;"""";CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1))"
        Rng = Ruota.getCellRangeByName("Q4:AN4")
        Rng.fillAuto(com.sun.star.sheet.FillDirection.TO_RIGHT, 1)
   Next x
Next i
End Sub


Sub Reset1()
beep

If MsgBox("Sei sicuro di voler resettare tutte le estrazioni ???", 64+4, "RESET")  = 6 Then
   Doc = ThisComponent
   Sh = Doc.Sheets.GetByName("Pronostico")
   Sh.GetCellRangeByName("AC5:AG14").ClearContents(1)
   Cell = Sh.getCellRangeByName("AC5")
   ThisComponent.CurrentController.Select(Cell) 
End If
End Sub

[arckborg]

Perfetto. Grazie infinite Gaetanopr

[arckborg]

Carissimo Gaetanopr, non avendo testato a sufficienza la macro che mi avevi suggerito, mi sono poi accorto che in realta' essa non era pienamente conforme a quanto avevo richiesto. Onde evitare ulteriori disguidi, pertanto, vi ho inviato di nuovo tramite dropbox sia il file calc PrimeNumberSystem che le istruzioni relative alle mie richieste di correzione/integrazione.
Un cordiale saluto, unitamente ai miei piu' sinceri Auguri di Buon Natale e di un sereno e Felice Anno nuovo, a Voi tutti e agli gli utenti del Forum.
Arch. A. Borghini

[Gaetanopr]

...mi sono poi accorto che in realta' essa non era pienamente conforme a quanto avevo richiesto....

Salve, in realtà la macro svolgeva quanto specificato tranne l'aggiornamento della formula in O1, il primo punto è stato cambiato radicalmente, una cosa è dire verificare che la data di estrazione non sia inserita più volte un'altra cosa è dire verificare che non vengano inseriti i dati della stessa estrazione, nel primo caso si effettua una verifica sulla data che sia univoca nel secondo caso si verifica l'intera estrazione numerica che non sia ripetuta a prescindere dalla data.

Codice: Seleziona tutto

Sub Insert
Dim Doc As Object
Dim Sh As Object
If MsgBox("Sei sicuro di voler inserire i nuovi estratti nelle rispettive Ruote ???", 64+4, "INSERT")  = 7 Then EXIT SUB
Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Pronostico")
Range = Sh.getCellRangeByName("AB5:AG14")
oRangeVuota = Range.queryEmptyCells.RangeAddresses
if UBound(oRangeVuota)>= 0 then 
   MsgBox("ATTENZIONE !!! Nel tabellone non sono stati ancora inseriti tutti gli estratti delle 10 Ruote", 16, "INSERT") 
   EXIT SUB
End If   
Ruote = Sh.getCellRangeByName("AB5:AB14").GetDataArray
'DataEstrazione = Sh.GetCellRangeByName("W2").Value

RigaIn = 5
For i = 0 To Ubound(Ruote)
   Ruota = Doc.Sheets.GetByName(Ruote(i)(0))
   Dati = Sh.getCellRangeByName("AC" & RigaIn+i & ":AG" & RigaIn+i & "").GetDataArray
   Estrazione = Join(Dati(0))
   c = Ruota.createCursor
   c.gotoEndOfUsedArea(false) 
   LastRow = c.RangeAddress.EndRow
   INSERITO = False 
   For n = LastRow To 5 Step - 1 
       If Ruota.GetCellByPosition(1, n).String <> "" Then LastRow = n : exit for
   Next n
   For n = LastRow To 5 Step - 1
        NumeriEstratti = Ruota.GetCellRangeByPosition(3, n, 7, n).GetDataArray
        If Estrazione = Join(NumeriEstratti(0)) Then INSERITO = True : exit For
   Next n

        If INSERITO = True Then MsgBox("Estrazione per la ruota " & Ruota.Name & " già inserita", 64, "INSERT")
        If INSERITO = False Then
           Ruota.UnProtect("")
          'If Ruota.GetCellByPosition(1+x, LastRow).Value = DataEstrazione Then MsgBox ("Estrazione per la ruota " & Ruota & " già inserita", 64, "INSERT") : exit For
           Ruota.GetCellRangeByPosition(3+x, LastRow+1, 7+x, LastRow+1).SetDataArray(Dati())
           Ruota.GetCellRangeByName("P5").FormulaLocal = "=SE(D6=0 O(MAX(B6:B" & LastRow+2 & ")<=45);""–"";MAX(B6:B" & LastRow+2 & ")-45+5)"
           Ruota.GetCellRangeByName("O1").FormulaLocal = "=CONTA.SE($M$"& LastRow+2-45 & ":$M$" & LastRow+2 & ";0)/45"
           Ruota.GetCellRangeByName("Q4").FormulaLocal= "=SE(CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1)<=1;"""";CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1))"
           Rng = Ruota.getCellRangeByName("Q4:AN4")
           Rng.fillAuto(com.sun.star.sheet.FillDirection.TO_RIGHT, 1)
           Ruota.Protect("")
        End If
Next i
End Sub

Buone feste

[arckborg]

Per testare l’ultima versione della Macro in oggetto ho provato ad inserire gli Estratti gia’ sortiti nella precedente Estrazione del 22/12/2022.
Orbene cliccando sul pulsante “INSERT”, dapprima mi compare il messaggio: “Sei sicuro di voler inserire i nuovi estratti nelle rispettive Ruote ???” (OK);
poi, cliccando sul pulsante “SI”, mi compare il messaggio di avvertimento: “ATTENZIONE !!! Gli estratti della Ruota di BA sono gia’ stati inseriti” (OK);
infine, cliccando sul pulsante “OK”, mi compare il seguente messaggio di Errore: “Operazione non supportata. Chiamata di procedura non valida.”
Evidentemente c’e’ un errore nella compilazione della macro.
A parte, su DropBox, allego le relative Schermate (pdf da 446 Kb).
Grazie di Nuovo Gaetanopr, e Buone Feste a Tutti.

[Gaetanopr]

Restituisce un errore nel msgbox, a me funziona bene puoi cambiare così ma non credo cambi qualcosa

Codice: Seleziona tutto

Sub Insert
Dim Doc As Object
Dim Sh As Object
If MsgBox("Sei sicuro di voler inserire i nuovi estratti nelle rispettive Ruote ???", 64+4, "INSERT")  = 7 Then EXIT SUB
Doc = ThisComponent
Sh = Doc.Sheets.GetByName("Pronostico")
Range = Sh.getCellRangeByName("AB5:AG14")
oRangeVuota = Range.queryEmptyCells.RangeAddresses
if UBound(oRangeVuota)>= 0 then 
   MsgBox("ATTENZIONE !!! Nel tabellone non sono stati ancora inseriti tutti gli estratti delle 10 Ruote", 16, "INSERT") 
   EXIT SUB
End If   
Ruote = Sh.getCellRangeByName("AB5:AB14").GetDataArray
'DataEstrazione = Sh.GetCellRangeByName("W2").Value

RigaIn = 5
For i = 0 To Ubound(Ruote)
   Ruota = Doc.Sheets.GetByName(Ruote(i)(0))
   NRuota = Ruota.Name
   Dati = Sh.getCellRangeByName("AC" & RigaIn+i & ":AG" & RigaIn+i & "").GetDataArray
   Estrazione = Join(Dati(0))
   c = Ruota.createCursor
   c.gotoEndOfUsedArea(false) 
   LastRow = c.RangeAddress.EndRow
   INSERITO = False 
   For n = LastRow To 5 Step - 1 
       If Ruota.GetCellByPosition(1, n).String <> "" Then LastRow = n : exit for
   Next n
   For n = LastRow To 5 Step - 1
        NumeriEstratti = Ruota.GetCellRangeByPosition(3, n, 7, n).GetDataArray
        If Estrazione = Join(NumeriEstratti(0)) Then INSERITO = True : exit For
   Next n

        If INSERITO = True Then MsgBox("Estrazione per la ruota " & NRuota & " già inserita", 64, "INSERT")
        If INSERITO = False Then
           Ruota.UnProtect("")
          'If Ruota.GetCellByPosition(1+x, LastRow).Value = DataEstrazione Then MsgBox ("Estrazione per la ruota " & Ruota & " già inserita", 64, "INSERT") : exit For
           Ruota.GetCellRangeByPosition(3+x, LastRow+1, 7+x, LastRow+1).SetDataArray(Dati())
           Ruota.GetCellRangeByName("P5").FormulaLocal = "=SE(D6=0 O(MAX(B6:B" & LastRow+2 & ")<=45);""–"";MAX(B6:B" & LastRow+2 & ")-45+5)"
           Ruota.GetCellRangeByName("O1").FormulaLocal = "=CONTA.SE($M$"& LastRow+2-45 & ":$M$" & LastRow+2 & ";0)/45"
           Ruota.GetCellRangeByName("Q4").FormulaLocal= "=SE(CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1)<=1;"""";CONTA.SE(Q" & LastRow+2-45 & ":Q" & LastRow+2 & ";1))"
           Rng = Ruota.getCellRangeByName("Q4:AN4")
           Rng.fillAuto(com.sun.star.sheet.FillDirection.TO_RIGHT, 1)
           Ruota.Protect("")
        End If
Next i
End Sub

Se pure così non funziona, togli la variabile e vediamo come procede

Codice: Seleziona tutto

If INSERITO = True Then MsgBox("Estrazione per la ruota già inserita", 64, "INSERT")

oppure così

Codice: Seleziona tutto

  If INSERITO = True Then MsgBox("Estrazione per la ruota " & Ruota.Name & " già inserita")

oppure con la l'istruzione print

Codice: Seleziona tutto

 If INSERITO = True Then Print "Estrazione per la ruota " & Ruota.name & " già inserita"

[arckborg]

Gaetanopr, scusami per il continuo disturbo che ti arreco, ma ho provato piu' volte a testare le varie macro che mi hai suggerito ma ho riscontrato diversi ed ulteriori problematiche.
Via DropBox, comunque, ti ho inviato il relativo riscontro.
Grazie di nuovo.... e buon Natale.

[Gaetanopr]

Semplici screenshot puoi allegarli anche qui, evitando l'uso dell'email.

[arckborg]

Salve Gaetanopr, non ti ho inviato dei semplici screenshoot ma anche il file in calc "PrimeNumberSystem" per complessivi 3 MB.
(P.S.- La password del suddetto file calc e' vuota).
Un saluto... ed un sereno Buon Natale.

[arckborg]

Scusami tanto Gaetanopr ma questa sera ho riprovato di nuovo a testare la macro che mi hai inviato oggi pomeriggio ed ora sembra funzionare tutto per il meglio. Forse oggi pomeriggio ero oltremodo stanco e stressato.
Scusami di nuovo per lo spiacevole disguido occorsomi.
BUON NATALE

[Gaetanopr]

Di nulla

[Novarest]

Salve. Mi sono accorto solo ora di questo topic e anche se in gravissimo ritardo volevo chiedere se possibile,dove sono sti files che l'utente Arckborg ha inviato tramite Dropbox. Nei vari paragrafi non c'è nulla,si vedono soltanto le macro di Gaetano

[arckborg]

Caro Novarest, il file in oggetto (2,5 Mb) non e' in alcun sito; tuttavia se mi invii la tua email vedro' di inviartelo.
Un cordiale saluto.

[Novarest]

Ciao. Va bene,tramite un msg privato adesso ti scriverò la mia email ma non ho capito perché i tuoi vari files Dropbox non li hai resi pubblici direttamente qui su questo topic

[Novarest]

Ti ho mandato il mio indirizzo alla tua boxmail