Moderatori: Anthony47, Flash30005
nelson1331 ha scritto:Ciao Anthony47,
ogni tanto mi faccio vivo, per proporti nuovi test sui 90 numeri del lotto.
Questa volta, parliamo di classi e radici quadrate.
Esprimo meglio le classi :
2 numeri = ambo
3 numeri = terno
4 Numeri = quaterna
5 Numeri = cinquina
6 Numeri = sestina
7 Numeri = settina
Per la mia richiesta, vista la mole di dati che verranno movimentati, soprattutto dalle settine, penso che basti ed avanzi.
Parliamo delle radici quadrate, applicando ad ogni classe il suo quadrato.
Se avessi la coppia di ambi 31 e 47 il seguito sarebbe :
31^2+47^2=961+2209=3170
Infine : radice quadrata di 3170 = 56,3027 Questo risultato, implica dei decimali ed a me non interessa.
Questa coppia, percio' la escludo.
Cosa serve a me ?
Solo quelle linee che, per ogni classe, abbiano resto=zero.
L' esempio piu' facile da comprendere e' la coppia di ambi 3.4 ----> Teorema di Pitagora
3^2+4^2=9+16=25 Radice quadrata di 25 = 5 resto =zero Perfetta Ok la prendo.
Il programma dovrebbe percio' evidenziarmi in ordine : prima l' indice di posizione, poi gli elementi che compongono quella classe.
Nello specifico caso, l' indice di posizione della coppia 3.4 e' il 178.
Ho gia' fatto questo lavoro per la classe =2 trovando 56 condizioni soddisfacenti.
Ho gia' fatto questo lavoro per la classe =3 dove ho trovato 607 condizioni soddisfacenti.
Ho gia' fatto questo lavoro per la classe =4 trovando 9772 condizioni soddisfacenti.
Dalla 5° classe in poi fino alla 7°, chiedo il tuo aiuto.
Grazie se potrai.
Nelson
Dim wArr() As Long, myI As Long, Level As Long, LastN As Long
Dim OArr(1 To 10000, 1 To 9) As Integer, LB As Double, ColOut As Long
Sub MainBah()
Dim myTim As Single
'
LastN = 90
Level = Range("A1").Value
Range("A2").Resize(Rows.Count - 1, Level * 3 + 5).ClearContents
DoEvents: DoEvents
LB = 10 ^ (-15)
ColOut = 1
ReDim wArr(1 To Level)
myTim = Timer
Application.ScreenUpdating = False
myI = 0
Call RecurBah(1)
If myI > 0 Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level).Value = OArr
End If
Application.ScreenUpdating = True
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Sub RecurBah(ByVal Colonna As Long)
'
If Colonna = Level Then
Do
wArr(Colonna) = wArr(Colonna) + 1
Call CkArr(Level)
If wArr(Colonna) - Colonna + Level >= LastN Then
Exit Do
End If
Loop
goBack = True
Exit Sub
Else
If Not wArr(Colonna) - Colonna + Level >= LastN Then
Do
wArr(Colonna) = wArr(Colonna) + 1
wArr(Colonna + 1) = wArr(Colonna)
If wArr(Colonna) - Colonna + Level >= LastN Then Exit Do
Call RecurBah(Colonna + 1)
Loop
End If
End If
End Sub
Sub CkArr(J As Long)
Dim I As Long, WVal As Long, SRVal As Double
'
For I = 1 To J
WVal = WVal + wArr(I) ^ 2
Next I
SRVal = WVal ^ 0.5
If (SRVal - Int(SRVal)) < LB Then
myI = myI + 1 '
For I = 1 To Level
OArr(myI, I) = wArr(I)
Next I
If myI = UBound(OArr) Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level).Value = OArr
Erase OArr
myI = 0
DoEvents
End If
End If
End Sub
Non ho proprio capito che cosa e' questo "indice di posizione", in prima battuta mi verrebbe da dire "Si posiziona dopo il precedente e prima del successivo"; ma credo tu voglia qualcosa di diverso, prova a spiegarlo con qualche esempio.Manca un piccolo ma, per me significativo tassello : l' indice di posizione, che se possibile, dovresti inserire all' inizio di ciascuna riga, cioe' prima delle formazioni di ogni classe. In sintesi e' questa la domanda : dove si colloca, quella formazione che tu hai individuato ?
Dim wArr() As Long, myI As Long, Level As Long, LastN As Long
Dim OArr(1 To 10000, 0 To 9) As Long, LB As Double, ColOut As Long, myColl As Long
Sub MainBah()
Dim myTim As Single
'
LastN = 90
Level = Range("A1").Value
Range("A2").Resize(Rows.Count - 1, Level * 3 + 5).ClearContents
DoEvents: DoEvents
LB = 10 ^ (-15)
ColOut = 1
ReDim wArr(1 To Level)
myTim = Timer
Application.ScreenUpdating = False
myI = 0
myColl = 0
Call RecurBah(1)
If myI > 0 Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
End If
Application.ScreenUpdating = True
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Sub RecurBah(ByVal Colonna As Long)
'
If Colonna = Level Then
Do
wArr(Colonna) = wArr(Colonna) + 1
Call CkArr(Level)
If wArr(Colonna) - Colonna + Level >= LastN Then
Exit Do
End If
Loop
goBack = True
Exit Sub
Else
If Not wArr(Colonna) - Colonna + Level >= LastN Then
Do
wArr(Colonna) = wArr(Colonna) + 1
wArr(Colonna + 1) = wArr(Colonna)
If wArr(Colonna) - Colonna + Level >= LastN Then Exit Do
Call RecurBah(Colonna + 1)
Loop
End If
End If
End Sub
Sub CkArr(J As Long)
Dim I As Long, WVal As Long, SRVal As Double
'
If myColl = 2147483647 Then
Debug.Print Now
myColl = 0
End If
myColl = myColl + 1
If myColl = 2147483647 Then myColl = 0
For I = 1 To J
WVal = WVal + wArr(I) ^ 2
Next I
SRVal = WVal ^ 0.5
If (SRVal - Int(SRVal)) < LB Then
myI = myI + 1 '
OArr(myI, 0) = myColl
For I = 1 To Level
OArr(myI, I) = wArr(I)
Next I
If myI = UBound(OArr) Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
Erase OArr
myI = 0
DoEvents
End If
End If
End Sub
Dim wArr() As Long, myI As Long, Level As Long, LastN As Long, SaveNum As Long, iFName As String
Dim OArr(1 To 10000, 0 To 9) As Long, LB As Double, ColOut As Long, myColl As Long
Sub MainBah()
Dim myTim As Single
'
LastN = 90
Level = Range("A1").Value
Range("A2").Resize(Rows.Count - 1, Level * 3 + 5).ClearContents
DoEvents: DoEvents
LB = 10 ^ (-15)
ColOut = 1
ReDim wArr(1 To Level)
myTim = Timer
Debug.Print ">>> Starting, " & Level, Now
iFName = ThisWorkbook.FullName
ThisWorkbook.Sheets(1).Cells(1, 3) = "'" & Format(SaveNum, "0000")
DoEvents
Application.ScreenUpdating = False
myI = 0
myColl = 0
Call RecurBah(1)
If myI > 0 Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
End If
Application.ScreenUpdating = True
Debug.Print "<<< Completed:", Now
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Sub RecurBah(ByVal Colonna As Long)
'
If Colonna = Level Then
Do
wArr(Colonna) = wArr(Colonna) + 1
Call CkArr(Level)
If wArr(Colonna) - Colonna + Level >= LastN Then
Exit Do
End If
Loop
goBack = True
Exit Sub
Else
If Not wArr(Colonna) - Colonna + Level >= LastN Then
Do
wArr(Colonna) = wArr(Colonna) + 1
wArr(Colonna + 1) = wArr(Colonna)
If wArr(Colonna) - Colonna + Level >= LastN Then Exit Do
Call RecurBah(Colonna + 1)
Loop
End If
End If
End Sub
Sub CkArr(J As Long)
Dim I As Long, WVal As Long, SRVal As Double
'
If myColl = 2147483647 Then
Debug.Print Now
myColl = 0
End If
myColl = myColl + 1
'' If myColl = 2147483647 Then myColl = 0
For I = 1 To J
WVal = WVal + wArr(I) ^ 2
Next I
SRVal = WVal ^ 0.5
If (SRVal - Int(SRVal)) < LB Then
myI = myI + 1 '
OArr(myI, 0) = myColl
For I = 1 To Level
OArr(myI, I) = wArr(I)
Next I
If myI = UBound(OArr) Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
'Se superiore a.. salva copia:
If ColOut > 10 Then
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
Call SaveNow(1)
End If
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
Erase OArr
myI = 0
DoEvents
End If
End If
End Sub
Sub SaveNow(Dummy As Long)
'
Debug.Print Now, SaveNum, myColl
'Mostra avanzamento:
Application.ScreenUpdating = True
DoEvents
'Salva copia:
ThisWorkbook.SaveCopyAs Replace(iFName, ".xlsm", "_" & Format(SaveNum, "0000") & ".xlsm", , , vbTextCompare)
'reset valori:
SaveNum = SaveNum + 1
ThisWorkbook.Sheets(1).Cells(1, 3) = "'" & Format(SaveNum, "0000")
ColOut = 1
ThisWorkbook.Sheets(1).Range("A2").Resize(Rows.Count - 2, 100).ClearContents
DoEvents
Application.ScreenUpdating = False
End Sub
Torna a Applicazioni Office Windows
formattare una colonnacon numeri senza virgolaSalve Autore: giorgioa |
Forum: Applicazioni Office Windows Risposte: 5 |
Come nascondere I Numeri non Appartenenti Al Mese Deside Autore: Maury170419 |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 34 ospiti