Condividi:        

PICCOLA AGGIUNTA SU MACRO

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 30/12/13 13:09

Ciao Flash, chiedo scusa:
Questa va aggiunta sotto la prima macro oppure in altro modulo?
Oppure sostituisce la prima macro?
Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Sponsor
 

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 30/12/13 13:14

sostituisce la macro avente lo stesso nome
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 30/12/13 13:46

L'ho fatto proprio in questo momento ma, non aggiunge agli eventi sfaldati, la riga successiva che rimette in gioco la medesima cinquina.
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 30/12/13 15:09

Ciao Flash, innanzitutto grazie per quanto stai facendo e per l’aiuto che stai apportando a questa mia ricerca che da otto mesi sto portando avanti e non ho ancora mollato.
A dire il vero: da un mesetto sto esaminando cosa succede con questa ricerca che mi sta intrigando non poco.

Ti allego questo foglio che prende in considerazione esclusivamente una ruota (Venezia), con novanta spie e quindi novanta cinquine aggregate. In archivio ci sono quaranta estrazioni e, partendo dalla prima (l’8747), si può verificare la macro che hai modificato.

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

Orbene, alla prima estrazione successiva (8748) si ha quanto segue:

Spie ripetute e aggiunte, quindi a ritardo a ritardo “0” = 5; righe 61-64-71-80-82.
Fin qui tutto ok come prima.

Eventi sfaldati alla 8778 = 12. Righe <11-22-37-66-74-75-95-96-101-105-106-111> di cui: otto ambi e quattro terni.
Noterai che a questi eventi sfaldati, manca la riga (stringa) successiva che deve rimettere in gioco la stessa cinquina appena sfaldata; che è poi quanto ho chiesto con questa modifica.

Se questo non avviene, le cinquine appena sfaldate, non saranno più prese in considerazione e quindi nell’estrazione successiva ci ritroveremmo con 12 cinquine in meno.

Note:
Volendo ripartire d’all’inizio basta copiare dal foglio “Att. Originale alla 8747” e inserire nel foglio “Attuali”. Lanciare la macro appena corretta e avrai gli esiti su indicati.
Ciao e buona giornata.
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 30/12/13 18:33

Quindi mi stai dicendo che non è cambiato nulla rispetto a prima?

Se così allora ripristino la riga codice precedente e modifico la macro in questa maniera
Codice: Seleziona tutto
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 Trim(Ws2.Range("N" & RR1).Value) = "Sto" And Ws2.Range("J" & RR1 + 1).Value <> 0 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("J" & RR1 + 1).Value = 0
                Ws2.Range("K" & RR1 + 1).ClearContents
                Ws2.Range("N" & RR1).Value = "Att"
                Ws2.Range("O" & RR1 + 1).ClearContents
                Ws2.Range("P" & RR1).Value = "in corso"
                End If
            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


Prova e fai sapere

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 30/12/13 21:18

Ciao Flash, ci siamo quasi:

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

Su nove cinquine sfaldate sei sono corrette (riga aggiunta); contrassegnate dalla linea nera senza la freccetta in testa.
Le prime tre invece, non ha aggiunto nessuna riga (contrassegnate con freccetta).

Ho rimesso gli attuali di partenza (indice 8747); ho inserito la successiva (8748) e gli esiti sono quelli colorati in giallo.
Sei giusti, tre mancanti!
Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 30/12/13 21:37

Vi è anche un altro inconveniente: sulle sei giuste la riga aggiunta, deve riportare "Att" col. "N"; nulla nella colonna successiva "O" e "in corso" nella colonna "P" che va bene.
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 30/12/13 23:09

Prova questa
Codice: Seleziona tutto
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 Trim(Ws2.Range("N" & RR1).Value) = "Sto" And Ws2.Range("J" & RR1 + 1).Value <> 0 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("J" & RR1 + 1).Value = 0
            Ws2.Range("K" & RR1 + 1).ClearContents
            Ws2.Range("N" & RR1 + 1).Value = "Att"
            Ws2.Range("O" & RR1 + 1).ClearContents
            Ws2.Range("P" & RR1 + 1).Value = "in corso"
        End If
        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


Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 00:13

Gloria a Dio!

Mi pareva strano che tu non riuscissi anche in questa impresa “per la verità non facile”.

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

Vi è però un piccolo aggiusto anche nell’altra macro “TrovaAgg” che ora, sfasa i gruppi.
Come puoi vedere da Immagine, le colonne che riguardano gli eventi sfaldati, riportano in R:U i valori di un gruppo 2; che ora è divenuto UNIVOCO.
In questo caso dovremmo avere solamente in “R=1” come gli altri univoci; in “S=0”.
La cinquina, infatti, riparte da zero.

Ancora un pochino del tuo tempo e hai perfezionato magnificamente questo lavoro.

INFINITAMENTE GRAZIE!!!!!!!!!!!!!!!!!
Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 00:48

Forse ho esultato troppo in fretta!

Colonne “J-M-N” non si aggiornano i valori.
All’estrazione successiva i valori citati sono rimasti alla 8748; così anche per gli altri “0” della colonna “J” che hanno incrementato di una riga la spia ripetuta.

https://dl.dropboxusercontent.com/u/182 ... 20ZERI.PNG

Ciao

Mi edito
gli zero che aggiornano la spia, vanno bene!
Sono solo quelli dopo gli storici che restano all'estrazione precedente.
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 00:55

La macro TrovaAgg non è stata modificata pertanto lo "sfasamento" non dipende da essa
Non so se questa versione possa andare bene perché mi sembra di aver trovato gli stessi dati in un file precedente a tutte le modifiche, comunque prova
Codice: Seleziona tutto
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 Trim(Ws2.Range("N" & RR1).Value) = "Sto" And Ws2.Range("J" & RR1 + 1).Value <> 0 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("J" & RR1 + 1).Value = 0
            Ws2.Range("K" & RR1 + 1).ClearContents
            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
        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


Ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 01:05

Lucio Peruggini ha scritto:Colonne “J-M-N” non si aggiornano i valori


Ma in J non deve esserci 0 (zero)? Perché dici che non si aggiorna?
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 01:30

Non si aggiorna all'estrazione successiva.
Infatti dall'immagine allegata noterai che ho lanciato la macro con dentro la 8749 e quindi i valori della 8748 (che erano a ritardo zero), dovevano portarsi a ritardo uno; compreso l'indice e la data che sono rimasti alla 8748.

Tutto questo indipendentemente dall'altra macro che aggiorna i gruppi che, come spiegato, andrebbe apportata una modifica che li aggiorni correttamente.
Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 02:00

Si, penso di aver capito dove è il bug
la modifica non andava fatta sulla macro TrovaSpia ma su TrovaAgg pertanto sostituisci entrambe le macro con questo codice
Codice: Seleziona tutto
Sub TrovaAgg()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
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
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"
           
                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("J" & RR1 + 1).Value = 0
                Ws2.Range("K" & RR1 + 1).ClearContents
                Ws2.Range("L" & RR1 + 1).Value = Ws1.Range("A2").Value
                Ws2.Range("M" & RR1 + 1).Value = CDate(Ws1.Range("B2").Value)
                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
               
             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
End Sub



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



Fai sapere se ci sono (e sicuramente ci saranno) altre modifiche da fare

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 03:23

Ciao Flash, commento la prima estrazione successiva, l’8747.

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

Orbene, la riga 11 e la 23 sono ok! Vi è però l’inghippo nelle righe successive che, nella colonna “I” devono riportare il medesimo valore di “L”. Cioè, le cinquine rimesse in gioco che ripartono con ritardo “0” dall’estrazione 8748. Se non si aggiusta questa colonna, all’estrazione successiva avvengono errori.
Inoltre, la macro non aggiorna le ultime sette righe della colonna “L” all’estrazione corrente; queste sono rimaste alla 8747.
Non aggiorna nemmeno le spie ripetute della colonna “C” che formano i gruppi. Infatti, nella colonna “R” abbiamo solamente spie univoche; mancano esattamente cinque gruppi di “spia ripetuta” che ho colorato di giallo in “C”.
Perciò, se non s’inquadrano queste prime tre mancanze, non posso andare oltre.

Notte
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 04:03

Prova (modificata solo TrovaAgg)
Codice: Seleziona tutto
Sub TrovaAgg()
Set Ws1 = Worksheets("Archivio")
Set Ws2 = Worksheets("Attuali")
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"
           
                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
               
             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
End Sub
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 13:02

Buona giornata
Intanto anticipo gli auguri per un buon anno nuovo a tutti.

Premetto che t’invio il foglio intero, faccio prima; piuttosto che inserire immagini.

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

Ciao Flash, ho inserito solamente la 8748 e già qui e prima di andare oltre, bisogna risolvere la situazione sulla ripetizione della spia che, è giustamente inserita nella colonna “C” ma nelle colonne “R:U” non sono marcati ne il gruppo, ne i ritardi che ho inserito io manualmente e colorati di giallo. In questo caso si tratta esclusivamente di gruppi (due); non può essere diversamente con una sola estrazione aggiunta.

Colonna “C” riga 64 vi è la prima spia ripetuta (num. 53); trattandosi di un gruppo le celle superiori che riguardano la prima spia uscita che era “univoca”, ora devono essere vuote.

Riga 67 (num. 55), idem come sopra.

Riga 75 (num. 61), in questo caso le celle superiori sono vuote; mancano come gli altri i valori in “R:U”.

Riga 86 (num. 69), come riga 75.

Riga 88 (num. 70), come riga 64; le celle superiori devono essere vuote.

Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 13:48

Ok
Adesso mandami il file con gli stessi dati ma con i valori giusti nelle celle da te menzionate
Cioè come vorresti che fosse, perché non ho capito nulla
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Flash30005 » 31/12/13 14:15

Volevo precisare che nel file da te inviato non esiste più nemmeno la macro TrovaNS che fa proprio quello che vorresti
Non vorrei che hai dimenticato di lanciarla

ciao
Flash
Win10 + Office 2010 Ita
"Fotografica" al servizio dell'immagine
Avatar utente
Flash30005
Moderatore
 
Post: 8517
Iscritto il: 27/09/07 11:44
Località: Roma +o-

Re: PICCOLA AGGIUNTA SU MACRO

Postdi Lucio Peruggini » 31/12/13 15:02

Ok, invio il file come deve presentarsi alla 8748. Ho solamente eliminato i valori sulle celle superiori che hanno formato i gruppi due.

Allego anche questa immagine laddove sono raffigurate dall’alto in basso sei formazioni di spia ripetuta e commento le colonne “R:U” solamente per il gruppo sei.

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

Numero 14 (gruppo 6)
Prima spia uscita estrazione 8723 (a quel momento era univoca); colonna “I”.
Seconda spia ripetuta 8754 (ha formato un gruppo due).
Terza spia ripetuta 8762 (ha formato un gruppo tre).
Quarta spia ripetuta 8776 (ha formato un gruppo quattro).
Quinta spia ripetuta 8777 (ha formato un gruppo cinque).
Sesta spia ripetuta 8780 a ritardo “0” senza che ci sia stato esito positivo fra la prima e la sesta ripetizione.
Abbiamo dunque un gruppo sei “Att” alla 8780, ultima in archivio.

Colonne “R:U”.

R48 = 6 colonna “C” (gruppo che si è formato dalla prima all’ultima spia uscita) ancora attuale.
S48 = 0 colonna “J” (ritardo ultima spia uscita).
T48 = 57 colonna “I” (ritardo accumulato dalla prima all’ultima spia) 8780-8763.
U48 = 57 è la differenza fra T - S. Ovviamente avendo “S” ritardo zero (spia ripetuta, avremo il medesimo valore di “T”.
Infatti, se guardi i valori di una spia non ripetuta nell’ultima estrazione la 8780, sono diversi.

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

Ciao
Lucio P.
Versione Office - 2013
Lucio Peruggini
Utente Senior
 
Post: 896
Iscritto il: 24/01/11 16:23

PrecedenteProssimo

Torna a Applicazioni Office Windows


Topic correlati a "PICCOLA AGGIUNTA SU MACRO":


Chi c’è in linea

Visitano il forum: Nessuno e 106 ospiti