ciao
ho una macro vecchia di 3/4 anni che mi sono accorto mi fa dei conti errati
non l ho fatta io , ero stato aiutato ma non ricordo "dove".
vorrei riuscire a correggere l errore se possibile.
passo a descrivere cosa fa.
si chiama Sub tabelpardisp ed e' nel modulo3
questa si trova nel fgl ambata1mo
ed analizza SOLO il 1mo estratto (col C) del fgl archivio
-conto i numeri pari e dispari e li scrive nelle celle BT21 e BU21
-cerca la sequenza massima realizzata indicando di quante estrazioni e' composta
riportando il risultato in BT23 e BU23
-mette la data inizio e fine di tale sequenza massima scrivendolo in BT24/25 e BU24/25
-conta quante volta si e' ripetuta questa sequenza massima, e lo scrive in BT27 BU27
- Codice: Seleziona tutto
Sub tabelpardisp()
'DISATTIVO LE VARIE APPLICATION
'IN MODO DA VELOCIZZARE L'ESECUZIONE DELLA MACRO
Dim xlCal As XlCalculation
With Application
.ScreenUpdating = False
.EnableEvents = False
xlCal = .Calculation
.Calculation = xlCalculationManual
End With
'-----------------------------------------------------------
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Area As Range
Dim Cl As Range
Dim Cl2 As Range
Dim UltC As Long
Dim Pari As Long
Dim Dispari As Long
Dim MaxSeq As Long
Dim Maxx As Long
Dim D_Inizio As Date
Dim D_Fine As Date
Dim DataI As Date
Dim DataF As Date
Dim Area2 As Range
Dim Nriga As Long
Dim Rip As Integer
Dim Resto As Integer
Dim t As Date
Worksheets("Ambata1mo").Unprotect ' togli protez
'VALORIZZO OGGETTI E VARIABILI
Set ws1 = ThisWorkbook.Sheets("Archivio_UK49s")
Set ws2 = ThisWorkbook.Sheets("Ambata1mo")
UltC = ws1.Range("C" & Rows.Count).End(xlUp).Row
Set Area = ws1.Range("C3:C" & UltC)
Rip = 1
t = Now
'CANCELLO I VALORI NELLE CELLE DI DESTINAZIONE
ws2.Range("BT21:BU21,BT23:BU25,BT27,BU27").ClearContents
'CICLO PER TROVARE PARI E DISPARI
For Each Cl In Area
If Cl Mod 2 = 0 Then
Pari = Pari + 1
Else
Dispari = Dispari + 1
End If
Next Cl
'INSERISCO I VALORI PARI E DISPARI IN "FOGLIO1"
ws2.Range("BT21").Value = Pari
ws2.Range("BU21").Value = Dispari
'CICLO CON 2 ITERAZIONI (UNA PER I PARI E UNA PER I DISPARI)
For Resto = 0 To 1
'CICLO OGNI CELLA DELLA COLONNA "C" TRANNE L'ULTIMA,
'VISTO CHE NON HO ALTRI VALORI DA VERIFICARE DOPO DI ESSA
For Nriga = 3 To UltC - 1
'LA VARIABILE RESTO NELLA PRIMA ITERAZIONE VERIFICA
'I NUMERI PARI, AVENDO VALORE 0; NELLA SECONDA
'VERIFICHERà I VALORI DISPARI, AVENDO VALORE 1
If ws1.Cells(Nriga, 3) Mod 2 = Resto Then
'AUMENTO LA SEQUENZA DI UNA UNITà
MaxSeq = MaxSeq + 1
'IMPOSTO LA DATA DI INIZIO SEQUENZA
D_Inizio = CDate(ws1.Cells(Nriga, 3).Offset(0, -1))
'IMPOSTO L'AREA DALLA CELLA SEGUENTE A QUELLA CICLATA,
'IN MODO DA VERIFICARE SE IL VALORE (PARO O DISPARO)
'è LO STESSO DELLA CELLA CICLATA
Set Area2 = ws1.Range(ws1.Cells(Nriga + 1, 3), ws1.Cells(UltC, 3))
'INIZIO A CICLARE L'AREA APPENA SETTATA
For Each Cl2 In Area2
'SE IL VALORE è LO STESSO
If Cl2 Mod 2 = Resto Then
'AUMENTO LA SEQUENZA DI UNA UNITà
MaxSeq = MaxSeq + 1
'IN OGNI CASO IMPOSTO LA DATA DI FINE SEQUENZA
D_Fine = CDate(Cl2.Offset(0, -1))
'ALTRIMENTI
Else
'LA VARIABILE "Maxx" SARà QUELLA CHE CONTERRà
'IL VALORE MAGGIORE DELLA SEQUENZA, MAN MANO CHE CICLERò
'LE CELLE
'SE IL VALORE DELLA MASSIMA SEQUENZA TROVATA AL MOMENTO,
'è MAGGIORE O UGUALE ALLA VALORE DELLA MASSIMA SEQUENZA
'MEMORIZZATA IN PRECEDENZA (NATURALMENTE ALLA PRIMA ITERAZIONE
'"Maxx" AVRà VALORE 0), ALLORA...
If MaxSeq >= Maxx Then
'QUI VERIFICO LA RIPETITIVITà DEL VALORE MASSIMO
If MaxSeq = Maxx Then
'SE è UGUALE INCREMENTO DI UNA UNITà
Rip = Rip + 1
Else
'ALTRIMENTI LO RIPORTO AL VALORE INIZIALE
Rip = 1
End If
'PASSO I VALORI MEMORIZZATI ALLE NUOVE VARIABILI
'CHE CONTERRANNO I VALORI FINALI...
DataI = D_Inizio
DataF = D_Fine
Maxx = MaxSeq
'...AZZERO LE VECCHIE VARIABILI PER INIZIARE UNA NUOVA ITERAZIONE....
D_Inizio = 0
D_Fine = 0
MaxSeq = 0
'...IMPOSTO LA RIGA DA DOVE RIPRENDERò L'ITERAZIONE...
Nriga = Cl2.Row
'...ESCO DAL CICLO INTERNO PER UNA NUOVA ITERAZIONE DEL CICLO ESTERNO
Exit For
'ALTRIMENTI AZZERO LE VECCHIE VARIABILI...
Else
D_Inizio = 0
D_Fine = 0
MaxSeq = 0
'....IMPOSTO LA RIGA DA DOVE RIPRENDERò L'ITERAZIONE....
Nriga = Cl2.Row
'...ED ESCO DAL CICLO INTERNO PER UNA NUOVA ITERAZIONE DEL CICLO ESTERNO
Exit For
End If
End If
Next Cl2
End If
Next Nriga
'INSERISCO I VALORI IN "FOGLIO1"
ws2.Cells(23, 72 + Resto).Value = Maxx
ws2.Cells(24, 72 + Resto).Value = DataI
ws2.Cells(25, 72 + Resto).Value = DataF
ws2.Cells(27, 72 + Resto).Value = Rip
Next Resto
'DISTRUGGO GLI OGGETTI
Set ws1 = Nothing
Set ws2 = Nothing
Set Area = Nothing
Set Area2 = Nothing
'RIATTIVO LE VARIE APPLICATION
With Application
.Calculation = xlCal
.EnableEvents = True
.ScreenUpdating = True
End With
'MESSAGGIO CHE RESTITUISCE IL TEMPO DI ESECUZIONE DELLA MACRO
MsgBox Format(Now - t, "HH:MM:SS"), vbInformation, "CODICE ESEGUITO IN......"
End Sub
il tutto e' corretto x i numeri PARI
mentre e' sbagliato x i numeri Dispari
la macro e' commentata ma non riesco a trovare come sistemarla.
allego il file
https://dl.dropboxusercontent.com/u/96374724/sequenze%20massima.rarciao
S.O. win10, Excell 2019