PICCOLA AGGIUNTA SU MACRO

[Flash30005]

Sostituisci solo la macro "TrovaNS" con questa

Codice: Seleziona tutto

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR

RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        If Ws2.Range("J" & RR) = 0 Then
            MinR = Ws2.Range("J" & RR - 1).Value
            Ws2.Range("S" & RR - 1).Value = MinR
            If Trim(Ws2.Range("N" & RR - 2).Value) = "Sto" Then
                Ws2.Range("T" & RR - 1).Value = MioMaxR
                Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
            End If
        Else
            Ws2.Range("T" & RR - 1).Value = MioMaxR
            Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
        End If
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub



EDIT ore 7:30 - Modificata macro

[Lucio Peruggini]

Ciao Flash e buona giornata.

Ci siamo quasi, vi è ancora una postilla da sistemare.
Alla 8779 è tutto ok!
Alla 8780, i valori precedenti in colonna “S” (8779) vengono cancellati; vedi Immagini.

https://dl.dropboxusercontent.com/u/182 ... 9%20OK.png

https://dl.dropboxusercontent.com/u/182 ... ellato.png

Ciao

[Flash30005]

Ho fatto una modifica alla macro TrovaNS ma testala bene

Codice: Seleziona tutto

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR
'If RR = 16 Then MsgBox RR
RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        MinR = Ws2.Range("J" & RR - 1).Value
        Ws2.Range("S" & RR - 1).Value = MinR
        If Ws2.Range("J" & RR) = 0 Then

            If Trim(Ws2.Range("N" & RR - 2).Value) = "Sto" Then
                Ws2.Range("T" & RR - 1).Value = MioMaxR
                Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
            End If
        Else
            Ws2.Range("T" & RR - 1).Value = MioMaxR
            Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
        End If
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub



Ciao

[Lucio Peruggini]

Ciao Flash, vanno bene i valori corretti agli eventi storici che ora in colonna “S” non sono più cancellati.
Ora però si ripete l’errore segnalato in precedenza (poi messo a posto) che, marca i valori degli “Univoci” (non devono esserci), anche nelle colonne T-U.
Vedi immagini alla 8779 e 8780.

https://dl.dropboxusercontent.com/u/182 ... nivoco.png

https://dl.dropboxusercontent.com/u/182 ... nivoco.png

Ciao

[Flash30005]

succede solo in quella riga?

prova così ma sto andando alla cieca

Codice: Seleziona tutto

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR
If RR = 110 Then MsgBox RR
RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        MinR = Ws2.Range("J" & RR - 1).Value
        Ws2.Range("S" & RR - 1).Value = MinR
        If Ws2.Range("J" & RR) = 0 Or Trim(Ws2.Range("N" & RR - 2).Value) = "Sto" Then
            Ws2.Range("T" & RR - 1).Value = MioMaxR
            Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
        End If
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Ciao

[Lucio Peruggini]

Sono andato avanti con le estrazioni per controllare cosa succede è, non credo di sbagliare:

Questa situazione si verifica solamente con la formazione univoca. Cioè, quando vi è un esito positivo in una formazione univoca viene rimessa in gioco la medesima cinquina; nell'estrazione successiva si verifica l'errore segnalato.
Solamente per gli univoci

Penso che, piuttosto che andare alla cieca, ti preparo un file che parte dall'inizio cioè "0" con le novanta cinquine complete; laddove sarà molto più facile individuare l'errore; poiché inizialmente avremo esclusivamente formazioni univoche.

La sostanza della macro non cambia minimamente e, come detto, di sicuro individuerai l'inghippo che sta facendo girar l'anima.

Cosa ne pensi? Anzi il file dovrei già averlo.
Ciao

[Flash30005]

Ma non va bene nemmeno l'ultima macro?
eppure avevo fatto un confronto e mi sembrava che andasse bene
comunque se non capisco la "dinamica" o logica non potrò mai impostare una macro risolutiva

Il file puoi anche inviarlo ma non ho tempo per studiare le spie, storico, ritardo e se deve o non deve essere riportato l'indice
Piuttosto pubblica dei numeri forniti dal programma, prima dell'estrazione così almeno vediamo se siamo gratificati del tempo impegnato per questo progetto.

ciao

[Lucio Peruggini]

Ma non va bene nemmeno l'ultima macro?
eppure avevo fatto un confronto e mi sembrava che andasse bene

A dire il vero mi ha spaventato la tua asserzione:
“prova così ma sto andando alla cieca”

La proposta di partire dall'inizio cioè con tutte le cinquine a “0” ritardo, serviva e serve proprio per capire la dinamica che accompagna lo svolgimento dei fatti partendo per l’appunto con delle “spie e quindi cinquine aggregate” che, nella fattispecie sarebbero tutti eventi ”UNIVOCI”.
Gradualmente e con il passare delle estrazioni questi eventi “Univoci” formeranno gruppi di “spie ripetute”.

Comunque, ora provo anche l’ultima modifica apportata prima d’inviarti il file proposto.

comunque se non capisco la "dinamica" o logica non potrò mai impostare una macro risolutiva

Hai pienamente ragione ma pensavo che in qualche modo e con l’esperienza che hai anche in tema ludologico, ci fossi in parte arrivato.
Se lo ritieni opportuno e per capire meglio il meccanismo evolutivo vai a questo collegamento dove, dalla A alla Z spiega tutto il procedimento e come sono arrivato fin qui.

http://lottostudio.forumfree.it/?t=67400276

Il file puoi anche inviarlo ma non ho tempo per studiare le spie, storico, ritardo e se deve o non deve essere riportato l'indice.

Mi chiedo allora: come puoi procedere se non afferri appieno cosa stai facendo?
“Tua asserzione”
Eppure nonostante tutto, ci sei vicino; quasi alla fine!
Il file che voglio inviarti proprio perché parte da “0” scopre per così dire le magagne iniziali.

Piuttosto pubblica dei numeri forniti dal programma, prima dell'estrazione così almeno vediamo se siamo gratificati del tempo impegnato per questo progetto.

Questo progetto e dopo otto mesi che ci lavoro non è ancora alla fine per sfornare previsioni; quello che stai facendo serve proprio a migliorare e cercare d’incastrare con poche battute, per così dire: il nostro sconosciuto futuro!
Infatti, non ci può essere un “futuro” senza le basi del “presente” che affonda le proprie radici nel “passato”.

Peraltro, la tua asserzione in questo forum mi sembrerebbe un pochino fuori luogo, non ti pare?
Non siamo in un forum di “Lotto” e senza fare tutta l’erba, un fascio, dove molta gente è presa per i fondelli da chissà quali vincite che sappiamo bene per il momento, non esistono o non si conoscono.

Provo l’altra correzione e ti farò sapere
ciao

[Lucio Peruggini]

Ho provato quest’ultima correzione:

1) Mi viene fuori quest’avviso. Gli dico ok, e termina l’esecuzione.
2) L’errore segnalato in precedenza che si manifestava all’estrazione 8780, ora si ripresenta già alla 8779.

https://dl.dropboxusercontent.com/u/182 ... EZIONE.PNG

https://dl.dropboxusercontent.com/u/182 ... 201%20.PNG

Problema non risolto; anzi sono diventati due.
ciao

[Flash30005]

per il messaggio devi eliminare la riga

Codice: Seleziona tutto

If RR = 110 Then MsgBox RR

nella macro TrovaNS

Per il secondo devo vedere...

[Flash30005]

Penso che ora debba andare bene per forza perché non intendo dedicarmi ulteriormente a queste macro

Codice: Seleziona tutto

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR
'If RR = 108 Then MsgBox RR
RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        MinR = Ws2.Range("J" & RR - 1).Value
        Ws2.Range("S" & RR - 1).Value = MinR
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


[Lucio Peruggini]

Ok, hai fatto il possibile ma non va ancora bene.

https://dl.dropboxusercontent.com/u/182 ... 208779.png

Le celle T-U di tutti i gruppi storici (sfaldati) sono vuote, non è marcato il ritardo che deve avere.

Quelle sottostanti sono Ok! Anche con estrazioni successive.

Mi spiace per il tempo che hai perso senza essere arrivato alla soluzione. Altre sì spiace enormemente anche al sottoscritto che di tempo ne ha dedicato da vendere.
Pazienza si vede che questa ricerca non deve andare a buon fine.

Comunque enormemente è la mia riconoscenza per quanto hai fatto; GRAZIE!!!

Un caro saluto

[Flash30005]

Le frecce che ora indicano che vorresti i dati in T e U
prima le avevi per indicarmi che proprio lì non volevi i dati (in altro punto ma con le stesse condizioni)



Uploaded with ImageShack.us


Quindi non trovo le condizioni idonee (se esistono) per fare "apparire" o "sparire" i dati

[Lucio Peruggini]

Flash ti stai confondendo, trovami il post dove ho affermato tali cose.
Non posso mai aver dichiarato una corbelleria simile! Tutti i dati inseriti da R a U sono importantissimi ai fini statistici preposti ma devono essere giusti.

Ti avevo proposto di partire dall'inizio e avrei inviato il file, sono convinto che con pochi passaggi avresti individuato gli errori che, secondo me vanno risolti a monte; partendo da "zero".

Ciao


Mi edito aggiungendo:

Nel file che hai a disposizione osserva per un momento come sono predisposti i dati di cui parliamo nel foglio "Originale corretto alla 8777" e ti renderai conto che non avrei mai potuto dire una cosa simile.

[Lucio Peruggini]

https://dl.dropboxusercontent.com/u/182 ... 20%20.xlsm

Gentilmente: come mai non parte questa macro?
Ci sono vincoli di qualche tipo?

Ho inserito le spie e cinquine che all'estrazione 8777 mancavano; sono i numeri spia colorati di giallo in colonna "C" e sono per l'esattezza 24 totali.

Ovviamente queste 24 cinquine aggiunte partono tutte da zero.
Ho fatto questo per avere tutte le 90 cinquine e quindi 90 spie ma la macro non parte.
Ciao

[Lucio Peruggini]

ALT, FERMA TUTTO; HO RISOLTO!!!

Tenendo per buono questa macro che marca i valori giusti e inserisce le righe agli eventi storici rimettendo in gioco la cinquina, basta salvarli su altro foglio e poi eliminare tutti gli eventi storici (quando ci sono) a ogni estrazione.
Funziona benissimo!

Non so se funzionerà con tutte le ruote ma credo di sì.

Ti ringrazio per il lavoro svolto e l'aiuto, senza del quale, tutto sarebbe finito in un "nulla di fatto".

Codice: Seleziona tutto

Sub TrovaAgg()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
MaxC = Evaluate("=Max(L:L)")
If Ws2.Range("I1").Value <= MaxC Then Exit Sub
AggS = 0
'Ws2.Range("K8:K1000").ClearContents
For CCA = 3 To 48 Step 5
Dim VNA(90) As Integer
RuA = UCase(Trim(Ws1.Cells(1, CCA)))
For NV = 1 To 90
For Onu = 1 To 5
If NV = Ws1.Cells(2, CCA + Onu - 1).Value Then VNA(Onu) = Ws1.Cells(2, CCA + Onu - 1).Value
Next Onu
Next NV
UR1 = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For RR1 = 8 To UR1 + 30

Ambo = ""
If UCase(Trim(Ws2.Range("B" & RR1).Value)) = UCase(Trim(RuA)) Then
For NV = 1 To 5
For NP = 1 To 5
If VNA(NV) = Ws2.Cells(RR1, 3 + NP).Value Then
Ambo = Ambo & " - " & VNA(NV)
End If
Next NP
Next NV
End If

If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value And Trim(Trim(Ws2.Cells(RR1, 14).Value)) <> "Sto" Then  '<<< ULTIMA STRINGA INSERITA

'If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value And Trim(Ws2.Cells(RR1, 12).Value) = "Att" Then   '<<< SOSTITUITA STRINGA - If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value Then

AggS = 1
    DiffRit = Ws1.Range("A2").Value - Ws2.Cells(RR1, 9).Value
    RuA2 = UCase(Trim(Ws2.Range("B" & RR1).Value))
    If RuA = RuA2 Then
        If Len(Ws2.Cells(RR1, 11).Value) < 5 Then
            If Len(Ambo) > 5 Then
                Ws2.Cells(RR1, 12).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1, 13).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Cells(RR1, 10).Value = DiffRit
                Ws2.Cells(RR1, 14).Value = "Sto"
                Ws2.Cells(RR1, 11).Value = Trim(Mid(Ambo, 3, Len(Ambo)))
                Ws2.Cells(RR1, 16).Value = "Positivo"
                Ws2.Cells(RR1, 15).Value = "Ambo"
                If Len(Ws2.Cells(RR1, 11).Value) > 8 Then Ws2.Cells(RR1, 15).Value = "Terno"
            If Ws2.Range("C" & RR1 + 1).Value <> Ws2.Range("C" & RR1).Value Or Ws2.Range("B" & RR1 + 1).Value <> Ws2.Range("B" & RR1).Value Then
                Rows(RR1 + 1 & ":" & RR1 + 1).Insert Shift:=xlDown
                Ws2.Range("A" & RR1 & ":P" & RR1).Copy Destination:=Ws2.Range("A" & RR1 + 1)
                Application.CutCopyMode = False
                Ws2.Range("K" & RR1 + 1).ClearContents
                Ws2.Range("I" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Range("L" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Range("M" & RR1 + 1).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Range("J" & RR1 + 1).Value = 0 'DiffRit
                Ws2.Range("N" & RR1 + 1).Value = "Att"
                Ws2.Range("O" & RR1 + 1).ClearContents
                Ws2.Range("P" & RR1 + 1).Value = "in corso"
                Ws2.Range("R" & RR1 + 1).Value = 1
                Ws2.Range("S" & RR1 + 1).Value = 0
            End If
             Else
                Ws2.Cells(RR1, 10).Value = DiffRit
                Ws2.Cells(RR1, 12).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1, 13).Value = CDate(Ws1.Range("B2").Value)
            End If
        End If
    End If
End If


Next RR1
Next CCA
If AggS = 1 Then TrovaSpia
TrovaNS
' Ws2.Range("M1") = Ws1.Range("B2").Value
End Sub


Private Sub TrovaSpia()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
For CCA = 48 To 3 Step -5
Dim VNA(5) As Integer
Dim VNC(90) As Integer
RuA = UCase(Trim(Ws1.Cells(1, CCA)))
VNC(1) = Ws1.Cells(2, CCA).Value
VNC(2) = Ws1.Cells(2, CCA + 1).Value
VNC(3) = Ws1.Cells(2, CCA + 2).Value
VNC(4) = Ws1.Cells(2, CCA + 3).Value
VNC(5) = Ws1.Cells(2, CCA + 4).Value
CCV = 0
For NV = 1 To 90
For Onu = 1 To 5
If NV = Ws1.Cells(2, CCA + Onu - 1).Value Then
CCV = CCV + 1
VNA(CCV) = Ws1.Cells(2, CCA + Onu - 1).Value
End If
Next Onu
Next NV
NewR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For NVR = 5 To 1 Step -1
    For RR1 = NewR To 8 Step -1
        If UCase(Trim(Ws2.Range("B" & RR1).Value)) = UCase(Trim(RuA)) Then
            If VNA(NVR) = Ws2.Cells(RR1, 3).Value And Trim(Ws2.Range("N" & RR1).Value) <> "Sto" Then
                Rows(RR1 + 1 & ":" & RR1 + 1).Insert Shift:=xlDown
                Ws2.Range("A" & RR1 & ":P" & RR1).Copy Destination:=Ws2.Range("A" & RR1 + 1)
                Application.CutCopyMode = False
                Ws2.Range("I" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1 + 1, 13).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Range("J" & RR1 + 1).Value = 0
                NewR = RR1
               GoTo SaltaNV
            End If
        End If
    Next RR1
SaltaNV:
Next NVR
Next CCA
UR1 = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For RR1 = 8 To UR1
Range("A" & RR1).Value = RR1 - 7
Next RR1

End Sub

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR
'If RR = 16 Then MsgBox RR
RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        MinR = Ws2.Range("J" & RR - 1).Value
        Ws2.Range("S" & RR - 1).Value = MinR
        If Ws2.Range("J" & RR) = 0 Then

            If Trim(Ws2.Range("N" & RR - 2).Value) = "Sto" Then
                Ws2.Range("T" & RR - 1).Value = MioMaxR
                Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
            End If
        Else
            Ws2.Range("T" & RR - 1).Value = MioMaxR
            Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
        End If
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub



Buona giornata

[Flash30005]

Flash ti stai confondendo, trovami il post dove ho affermato tali cose.
Non posso mai aver dichiarato una corbelleria simile!

Post dove affermi che vuoi i dati in T e U (04/01/14 00:12)

Ok, hai fatto il possibile ma non va ancora bene.

https://dl.dropboxusercontent.com/u/182 ... 208779.png

Le celle T-U di tutti i gruppi storici (sfaldati) sono vuote, non è marcato il ritardo che deve avere.

Post dove affermi che NON vuoi i dati in T e U (03/01/14 02:19 )

Siamo quasi alla frutta!

...riga 108 si è sfaldato come "Univoco" e quindi i valori in T-U non ci devono essere. In "S" invece, dev’esserci il ritardo 13 proveniente dalla colonna “J”.

https://dl.dropboxusercontent.com/u/182 ... Errori.PNG

Adesso sì, che "siamo arrivati proprio alla frutta"!

[Lucio Peruggini]

Ciao Flash, mi spiace ma non hai afferrato minimamente la dinamica di questo lavoro.

I gruppi da due in su comprendono le colonne R-S-T-U
Gli univoci comprendono esclusivamente le colonne R e S

Comunque, grazie. In qualche modo e con un pochetto di lavoro riesco a ottenere i dati corretti come specificato nel post precedente.

Ciao

[Lucio Peruggini]

Ciao Flash, buona giornata.

Sto facendo alcune prove e momentaneamente dovrei disattivare a quest’ultima macro la riga che si aggiunge in automatico rimettendo in gioco la cinquina dopo gli eventi positivi cioè storici; quelle che ripartono da zero.

https://dl.dropboxusercontent.com/u/182 ... GIUNTA.png

E’ troppo complicato senza danneggiare tutto il resto?
Basta mettere degli apici, e dove?

Se proprio non è possibile, lascio tutto com'è.

La macro è l’ultima cioè questa che riporto:

Codice: Seleziona tutto

'MACRO PER FORMAZIONI SPIA  - Di By Flash  / pc-facile.com  - Terminata in data 03/01/2014

Sub TrovaAgg()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
MaxC = Evaluate("=Max(L:L)")
If Ws2.Range("I1").Value <= MaxC Then Exit Sub
AggS = 0
'Ws2.Range("K8:K1000").ClearContents
For CCA = 3 To 48 Step 5
Dim VNA(90) As Integer
RuA = UCase(Trim(Ws1.Cells(1, CCA)))
For NV = 1 To 90
For Onu = 1 To 5
If NV = Ws1.Cells(2, CCA + Onu - 1).Value Then VNA(Onu) = Ws1.Cells(2, CCA + Onu - 1).Value
Next Onu
Next NV
UR1 = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For RR1 = 8 To UR1 + 30

Ambo = ""
If UCase(Trim(Ws2.Range("B" & RR1).Value)) = UCase(Trim(RuA)) Then
For NV = 1 To 5
For NP = 1 To 5
If VNA(NV) = Ws2.Cells(RR1, 3 + NP).Value Then
Ambo = Ambo & " - " & VNA(NV)
End If
Next NP
Next NV
End If

If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value And Trim(Trim(Ws2.Cells(RR1, 14).Value)) <> "Sto" Then  '<<< ULTIMA STRINGA INSERITA

'If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value And Trim(Ws2.Cells(RR1, 12).Value) = "Att" Then   '<<< SOSTITUITA STRINGA - If Ws2.Cells(RR1, 12).Value < Ws1.Range("A2").Value Then

AggS = 1
    DiffRit = Ws1.Range("A2").Value - Ws2.Cells(RR1, 9).Value
    RuA2 = UCase(Trim(Ws2.Range("B" & RR1).Value))
    If RuA = RuA2 Then
        If Len(Ws2.Cells(RR1, 11).Value) < 5 Then
            If Len(Ambo) > 5 Then
                Ws2.Cells(RR1, 12).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1, 13).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Cells(RR1, 10).Value = DiffRit
                Ws2.Cells(RR1, 14).Value = "Sto"
                Ws2.Cells(RR1, 11).Value = Trim(Mid(Ambo, 3, Len(Ambo)))
                Ws2.Cells(RR1, 16).Value = "Positivo"
                Ws2.Cells(RR1, 15).Value = "Ambo"
                If Len(Ws2.Cells(RR1, 11).Value) > 8 Then Ws2.Cells(RR1, 15).Value = "Terno"
            If Ws2.Range("C" & RR1 + 1).Value <> Ws2.Range("C" & RR1).Value Or Ws2.Range("B" & RR1 + 1).Value <> Ws2.Range("B" & RR1).Value Then
                Rows(RR1 + 1 & ":" & RR1 + 1).Insert Shift:=xlDown
                Ws2.Range("A" & RR1 & ":P" & RR1).Copy Destination:=Ws2.Range("A" & RR1 + 1)
                Application.CutCopyMode = False
                Ws2.Range("K" & RR1 + 1).ClearContents
                Ws2.Range("I" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Range("L" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Range("M" & RR1 + 1).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Range("J" & RR1 + 1).Value = 0 'DiffRit
                Ws2.Range("N" & RR1 + 1).Value = "Att"
                Ws2.Range("O" & RR1 + 1).ClearContents
                Ws2.Range("P" & RR1 + 1).Value = "in corso"
                Ws2.Range("R" & RR1 + 1).Value = 1
                Ws2.Range("S" & RR1 + 1).Value = 0
            End If
             Else
                Ws2.Cells(RR1, 10).Value = DiffRit
                Ws2.Cells(RR1, 12).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1, 13).Value = CDate(Ws1.Range("B2").Value)
            End If
        End If
    End If
End If


Next RR1
Next CCA
If AggS = 1 Then TrovaSpia
TrovaNS
' Ws2.Range("M1") = Ws1.Range("B2").Value
End Sub


Private Sub TrovaSpia()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
For CCA = 48 To 3 Step -5
Dim VNA(5) As Integer
Dim VNC(90) As Integer
RuA = UCase(Trim(Ws1.Cells(1, CCA)))
VNC(1) = Ws1.Cells(2, CCA).Value
VNC(2) = Ws1.Cells(2, CCA + 1).Value
VNC(3) = Ws1.Cells(2, CCA + 2).Value
VNC(4) = Ws1.Cells(2, CCA + 3).Value
VNC(5) = Ws1.Cells(2, CCA + 4).Value
CCV = 0
For NV = 1 To 90
For Onu = 1 To 5
If NV = Ws1.Cells(2, CCA + Onu - 1).Value Then
CCV = CCV + 1
VNA(CCV) = Ws1.Cells(2, CCA + Onu - 1).Value
End If
Next Onu
Next NV
NewR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For NVR = 5 To 1 Step -1
    For RR1 = NewR To 8 Step -1
        If UCase(Trim(Ws2.Range("B" & RR1).Value)) = UCase(Trim(RuA)) Then
            If VNA(NVR) = Ws2.Cells(RR1, 3).Value And Trim(Ws2.Range("N" & RR1).Value) <> "Sto" Then
                Rows(RR1 + 1 & ":" & RR1 + 1).Insert Shift:=xlDown
                Ws2.Range("A" & RR1 & ":P" & RR1).Copy Destination:=Ws2.Range("A" & RR1 + 1)
                Application.CutCopyMode = False
                Ws2.Range("I" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Cells(RR1 + 1, 13).Value = CDate(Ws1.Range("B2").Value)
                Ws2.Range("J" & RR1 + 1).Value = 0
                NewR = RR1
               GoTo SaltaNV
            End If
        End If
    Next RR1
SaltaNV:
Next NVR
Next CCA
UR1 = Ws2.Range("B" & Rows.Count).End(xlUp).Row
For RR1 = 8 To UR1
Range("A" & RR1).Value = RR1 - 7
Next RR1

End Sub

Private Sub TrovaNS()
Set Ws2 = Worksheets("Attuali")
UR = Ws2.Range("B" & Rows.Count).End(xlUp).Row
Ws2.Range("R8:U" & UR).ClearContents
MaxR = 0
ContaS = 1
For RR = 8 To UR

RuS1 = Trim(Ws2.Range("B" & RR).Value) & Trim(Ws2.Range("C" & RR).Value) & Trim(Ws2.Range("D" & RR).Value)
RuS2 = Trim(Ws2.Range("B" & RR + 1).Value) & Trim(Ws2.Range("C" & RR + 1).Value) & Trim(Ws2.Range("D" & RR + 1).Value)

If RuS1 = RuS2 Then
    If MaxR = 0 Then
        MioMaxR = Ws2.Range("J" & RR).Value
        MaxR = 1
    End If
    MinR = Ws2.Range("J" & RR + 1).Value
    ContaS = ContaS + 1
Else
MaxR = 0
    Ws2.Range("R" & RR).Value = ContaS
   
    If Trim(Ws2.Range("N" & RR - 1).Value) = "Sto" Then
        Ws2.Range("R" & RR).Value = 1
        Ws2.Range("R" & RR - 1).Value = ContaS - 1
        If Ws2.Range("J" & RR) = 0 Then
            MinR = Ws2.Range("J" & RR - 1).Value
            Ws2.Range("S" & RR - 1).Value = MinR
            If Trim(Ws2.Range("N" & RR - 2).Value) = "Sto" Then
                Ws2.Range("T" & RR - 1).Value = MioMaxR
                Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
            End If
        Else
            Ws2.Range("T" & RR - 1).Value = MioMaxR
            Ws2.Range("U" & RR - 1).Value = MioMaxR - MinR
        End If
   Else
        If ContaS > 1 Then
            Ws2.Range("S" & RR).Value = MinR
            Ws2.Range("T" & RR).Value = MioMaxR
            Ws2.Range("U" & RR).Value = MioMaxR - MinR
        End If
    End If
    ContaS = 1
If Ws2.Range("R" & RR).Value > 0 Then Ws2.Range("S" & RR).Value = Ws2.Range("J" & RR).Value
End If
Next RR
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub




Ciao

[Lucio Peruggini]

Ciao Flash, anche se non hai preso in considerazione quanto ho chiesto in quest'ultima, non ha importanza.

Desidero comunque ringraziarti per tutto quello che hai fatto e per il grandissimo aiuto che da anni ai sempre operato nei miei confronti.
Un caro saluto