ok...
come promesso ecco vers 1.47 colori 49k
http://dl.dropbox.com/u/96374724/luga.lotto49k.colori.1.47.rar
grazie
ciao
Moderatori: Anthony47, Flash30005
Sub ContaUscConsecutive()
Set Ws1 = Worksheets("Archivio_UK49s")
Set Ws2 = Worksheets("ritcolori")
Application.ScreenUpdating = False
Application.Calculation = xlManual
Ws2.Unprotect
URA = Ws1.Range("K" & Rows.Count).End(xlUp).Row
For RRC = 38 To 44
MyCol = Ws2.Range("B" & RRC).Value
ContaS = 0
ContaC = 0
MContaC = Ws2.Range("C" & RRC).Value
For RRA = 3 To URA
If Ws1.Range("K" & RRA).Value = MyCol Then
ContaC = ContaC + 1
If ContaC = MContaC Then ContaS = ContaS + 1
Else
ContaC = 0
End If
Next RRA
Application.EnableEvents = False
Ws2.Range("D" & RRC).Value = ContaS
Application.EnableEvents = True
Next RRC
Ws2.Protect
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ContaUscCons()
Set Ws1 = Worksheets("Archivio_UK49s")
Set Ws2 = Worksheets("ritcolori")
Application.ScreenUpdating = False
Application.Calculation = xlManual
Ws2.Unprotect
URA = Ws1.Range("K" & Rows.Count).End(xlUp).Row
For RRC = 38 To 44
MyCol = Ws2.Range("B" & RRC).Value
ContaS = 0
ContaC = 0
MContaC = 0
For RRA = 3 To URA
If Ws1.Range("K" & RRA).Value = MyCol Then
ContaC = ContaC + 1
If ContaC > MContaC Then MContaC = ContaC
Else
ContaC = 0
End If
Next RRA
Application.EnableEvents = False
Ws2.Range("C" & RRC).Value = MContaC
Application.EnableEvents = True
For RRA = 3 To URA
If Ws1.Range("K" & RRA).Value = MyCol Then
ContaC = ContaC + 1
If ContaC = MContaC Then ContaS = ContaS + 1
Else
ContaC = 0
End If
Next RRA
Application.EnableEvents = False
Ws2.Range("D" & RRC).Value = ContaS
Application.EnableEvents = True
Next RRC
Ws2.Protect
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
x gestire l'estrazione del mezzo giorno avrei bisogno di un aiuto
in quanto le macro ora presenti (correttamente), fanno riferimento all'archivio completo delle estrazioni
che si aggiorna in automatico , ma solo la sera dopo l'ultima estrazione.
Private Sub Worksheet_Change(ByVal Target As Range)
Area1 = "M15:M500 , q2 , q11"
Area2 = "D12"
If Application.Intersect(Target, Range(Area1)) Is Nothing Then GoTo saltaA
SColore = Target
Colora
saltaA:
If Application.Intersect(Target, Range(Area2)) Is Nothing Then Exit Sub
SColore = Target
For RR1 = 3 To 9
ColD1 = Range("D" & RR1).Value
If ColD1 = SColore Then
Application.EnableEvents = False
Range("E" & RR1).Value = 0
Application.EnableEvents = True
Else
For RR2 = 14 To 20
ColD2 = Range("D" & RR2).Value
Application.EnableEvents = False
If ColD1 = ColD2 Then
Range("E" & RR1).Value = Range("E" & RR2).Value + 1
Application.EnableEvents = True
Exit For
End If
Next RR2
End If
Next RR1
'Colora '<<<< Togliere commento se occorre avviare la macro Colora
End Sub
Sub MioAzz()
SColore = Range("D12").value
For RR1 = 3 To 9
ColD1 = Range("D" & RR1).Value
If ColD1 = SColore Then
Application.EnableEvents = False
Range("E" & RR1).Value = 0
Application.EnableEvents = True
Else
For RR2 = 14 To 20
ColD2 = Range("D" & RR2).Value
Application.EnableEvents = False
If ColD1 = ColD2 Then
Range("E" & RR1).Value = Range("E" & RR2).Value + 1
Application.EnableEvents = True
Exit For
End If
Next RR2
End If
Next RR1
end sub
Sub FreqNum()
Worksheets("ritardi").Range("F63:F111").ClearContents
MyData = Worksheets("ritardi").Range("F60").Value
URA = Worksheets("Archivio_UK49s").Range("B" & Rows.Count).End(xlUp).Row
For RRA = 3 To URA
If Worksheets("Archivio_UK49s").Range("B" & RRA).Value = MyData Then
MiaRiga = RRA
Exit For
End If
Next RRA
For Num = 1 To 49
MyCount = Evaluate("COUNTIF(Archivio_UK49s!C" & MiaRiga & ":I" & URA & "," & Num & ")")
Worksheets("ritardi").Range("F" & Num + 62).Value = MyCount
Next Num
End Sub
=INDIRETTO("Archivio_UK49s!B3:B"&CONTA.VALORI(Archivio_UK49s!$B:$B))
= Edate
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$F$60" Then Exit Sub
FreqNum
End Sub
'Private Sub Workbook_Open()
Dim NS(7) As Integer
Dim Terz(3) As Integer
Dim t(3) As Integer
UR1 = ws1.Range("B" & Rows.Count).End(xlUp).Row
For RR1 = 3 To UR1
For CC1 = 3 To 3 ' con 3 analiz solo 1mo estr, metti 8 x analiz i primi 6
NS(CC1 - 2) = ws1.Cells(RR1, CC1)
If NS(CC1 - 2) = 0 Then GoTo SaltaRR
Next CC1
For RR2 = RR1 + 1 To RR1 + ws2.Range("BD1").Value
For CT1 = 3 To 8
Terz(1) = ws1.Cells(RR2, CT1)
For CT2 = CT1 + 1 To 9 ' metti 8 se vuoi escludere dall'analisi il jolly
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 54 ospiti