Beh non era chiaro che dovesse conteggiare solo l'estrazione successiva
pertanto ho modificato e implementato anche con la prima macro
prova a vedere se questo, ora, va bene
ciao
Moderatori: Anthony47, Flash30005
Sub colormax()
'Dim ArCol, ACPoint As Integer
Dim aaaZ, ListCol, I As Integer, MyCol As String, ColCnt As Integer
Dim EstraCol
Set ListCol = Foglio14.Range("N61:N80")
ListCol.Offset(0, 1).ClearContents
With Foglio21
EstraCol = .Range("K3:K" & .Cells(Rows.Count, 11).End(xlUp).Row)
End With
For I = LBound(EstraCol, 1) To UBound(EstraCol, 1)
MyCol = EstraCol(I, 1)
aaaZ = Application.Match(MyCol, ListCol, 0)
If Not IsError(aaaZ) Then
If I > 1 Then
If EstraCol(I - 1, 1) = MyCol Then
ColCnt = ColCnt + 1
Else: ColCnt = 1
End If
If ColCnt > ListCol.Range("A1").Offset(aaaZ - 1, 1) Then _
ListCol.Range("A1").Offset(aaaZ - 1, 1) = ColCnt
Else
ColCnt = 1
ListCol.Range("A1").Offset(aaaZ - 1, 1) = ColCnt
End If
Else
ListCol.End(xlDown).Offset(1, 0) = MyCol
ListCol.End(xlDown).Offset(0, 1) = 1
End If
Next I
End Sub
Sub AmbiRA()
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Worksheets("Archivio_UK49s")
Set Ws2 = Worksheets("fibonacci_2num")
UR1 = Ws1.Range("C" & Rows.Count).End(xlUp).Row
For Col2 = 21 To 23
N1 = Ws2.Cells(4, Col2).Value
N2 = Ws2.Cells(5, Col2).Value
For RR1 = UR1 To 3 Step -1
For CC1 = 3 To 7
Na1 = Ws1.Cells(RR1, CC1).Value
For CC2 = CC1 + 1 To 8
Na2 = Ws1.Cells(RR1, CC2).Value
If (Na1 = N1 Or Na1 = N2) And (Na2 = N1 Or Na2 = N2) Then
Ws2.Cells(6, Col2).Value = UR1 - RR1
GoTo SaltaA
End If
Next CC2
Next CC1
Next RR1
SaltaA:
Next Col2
End Sub
Sub RitardiFib()
Application.ScreenUpdating = False
Application.Calculation = xlManual
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Worksheets("Archivio_UK49s")
Set Ws2 = Worksheets("fibonacci_2num")
Ws2.Range("T8:T37").ClearContents
UR1 = Ws1.Range("C" & Rows.Count).End(xlUp).Row
N1 = Ws2.[J7]
N2 = Ws2.[J8]
passo = 0
For RR1 = UR1 To 2 Step -1
For CC1 = 3 To 8
If Ws1.Cells(RR1, CC1).Value = N1 Or Ws1.Cells(RR1, CC1).Value = N2 Then
NC = Ws1.Cells(RR1, 1).Value
RNC = MNC - NC
MNC = NC
If passo > 0 Then
Ws2.Range("T" & passo + 7).Value = RNC
End If
passo = passo + 1
If passo > 30 Then GoTo Esci
GoTo SaltaRR1
End If
Next CC1
SaltaRR1:
Next RR1
Esci:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Vorresti contare il numero delle estrazioni tra un'uscita e l'altra indipendentemente se trattasi di uno o l'altro numero?
no.es il 34 è uscito alla penumltima estrazione n. 4848 del 2/2/2012 da questo momento contare le successive uscite?
Sub ContaSf()
Dim Ws1, Ws2 As Worksheet
Set Ws1 = Worksheets("Archivio_UK49s")
Set Ws2 = Worksheets("fibonacci_2num")
Ws2.Range("T8:T37").ClearContents
Dim Sf(30) As Integer
UR1 = Ws1.Range("C" & Rows.Count).End(xlUp).Row
N1 = Ws2.[J7]
N2 = Ws2.[J8]
For S = 1 To 30
Sf(S) = 0
Next S
passo = 0
For RR1 = 2 To UR1
For CC1 = 3 To 8
If Ws1.Cells(RR1, CC1).Value = N1 Or Ws1.Cells(RR1, CC1).Value = N2 Then
NC = Ws1.Cells(RR1, 1).Value
RNC = NC - MNC
If RNC > 30 Then GoTo SaltaRR1
MNC = NC
If passo > 0 Then
Sf(RNC) = Sf(RNC) + 1
End If
passo = 1
GoTo SaltaRR1
End If
Next CC1
SaltaRR1:
Next RR1
For S = 1 To 30
Ws2.Range("T" & S + 7).Value = Sf(S)
Next S
End Sub
''...
'...
For RR1 = 2 To UR1
For CC1 = 3 To 8
If Ws1.Cells(RR1, CC1).Value = N1 Or Ws1.Cells(RR1, CC1).Value = N2 Then
NC = Ws1.Cells(RR1, 1).Value
RNC = NC - MNC
MNC = NC '<<<<<<<<< portare qui
If RNC > 30 Then GoTo SaltaRR1 '<<<<<<<<<< esistente
'MNC = NC <<<<<<<<<<<<< era qui da spostare come indicato
'...
'...
Torna a Applicazioni Office Windows
Classi e radici quadrate applicate ai 90 numeri del lotto. Autore: nelson1331 |
Forum: Applicazioni Office Windows Risposte: 8 |
cercare e prelevare 128 estraz del lotto Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 6 |
Questo progetto (dedicato al lotto), si puo' realizzare ? Autore: nelson1331 |
Forum: Applicazioni Office Windows Risposte: 18 |
Visitano il forum: Nessuno e 116 ospiti