Option Explicit
Sub Main
Dim aL1 , aL2
Dim aS1 ,aS2 , aD1 , aD2
Dim b
If GetLunghetta ( "Inserire la prima lunghetta di 5 numeri separati da spazio" , aL1) Then
If GetLunghetta ( "Inserire la seconda lunghetta di 5 numeri separati da spazio" , aL2) Then
Call CalcolaSomme (aL1 , aS1)
Call CalcolaSomme (aL2 , aS2)
Call CalcolaDistanze (aL1 , aD1)
Call CalcolaDistanze (aL2 , aD2)
Call MostraValoriUgualiSuLunghetta (aL1 , aS1 ,"Somme uguali su prima lunghetta " & StringaNumeri (aL1) , "Somme")
Call MostraValoriUgualiSuLunghetta (aL2 , aS2 ,"Somme uguali su seconda lunghetta " & StringaNumeri (aL2) , "Somme")
Call MostraValoriUgualiSuLunghetta (aL1 , aD1 ,"Distanze uguali su prima lunghetta " & StringaNumeri (aL1) , "Distanze" )
Call MostraValoriUgualiSuLunghetta (aL2 , aD2 ,"Distanze uguali su seconda lunghetta " & StringaNumeri (aL2), "Distanze" )
Call MostraValoriUgualiTraLunghette ( aS1 , aS2 , "Somme uguali tra le somme" , "Somma")
Call Scrivi
Call MostraValoriUgualiTraLunghette ( aD1 , aD2 , "Distanze uguali tra distanze" , "Distanza")
b = True
End If
End If
If Not b Then
MsgBox "Nessun dato elaborato"
End If
End Sub
Function GetLunghetta (sTesto , aV)
Dim s
s = Trim(InputBox (sTesto ,"Inserire i numeri") )
ReDim aV(0)
Do While InStr(s , " ")
s = Replace (s , " " , " ")
Loop
Call SplitByChar( s , " " ,aV)
If UBound (aV) = 4 Then
GetLunghetta = True
End If
End Function
Sub CalcolaSomme ( aL , aSomme)
Dim k , kk , i
ReDim aSomme (GetCombinazioni(UBound(aL) +1))
For k =0 To UBound (aL)-1
For kk =k +1 To UBound (aL)
i = i +1
aSomme (i) = Fuori90 (Int(aL(k)) + Int(aL(kk)))
Next
Next
End Sub
Sub CalcolaDistanze ( aL , aDistanze )
Dim k , kk , i
ReDim aDistanze (GetCombinazioni(UBound(aL) +1))
For k =0 To UBound (aL)-1
For kk =k +1 To UBound (aL)
i = i +1
aDistanze (i) = DiffCiclometrica (Int(aL(k)) , Int(aL(kk)))
Next
Next
End Sub
Function GetCombinazioni (nQNumeri)
Dim k , t
t =0
For k = nQNumeri-1 To 1 Step -1
t = t +k
Next
GetCombinazioni = t
End Function
Sub MostraValoriUgualiSuLunghetta (aL,aValori , sTitolo , sDescr)
Dim k , kk , i , b
Dim nE , nQ
Dim aColori
aColori = Array (RGB(255,128,128), RGB(255,255,128),RGB(128,255,128) ,RGB(128,255,255) ,RGB(0,128,255) ,RGB(255,128,192) ,RGB(255,128,255),RGB(255,128,0) ,RGB(128,0,255))
nE = UBound( aValori )
nQ = UBound(aL) +1
ReDim aColoriCelle (nE)
ReDim aT (11)
ReDim aV (11)
ReDim aBUsati(10)
For k = 1 To nE -1
If Not (aBUsati(k)) Then
aBUsati (k) = True
b = False
For kk = k +1 To nE
If aValori (kk) = aValori (k) Then
aBUsati (kk) = True
If b = False Then i = i +1
b = True
aColoriCelle (k) = aColori (i)
aColoriCelle (kk) = aColori(i)
End If
Next
End If
Next
i =0
aT(1) = "Posizioni"
aV(1) = sDescr
For k = 1 To nQ-1
For kk = k+1 To nQ
i = i +1
aT(i+1) = k & "-" & kk
aV(i+1) = aValori (i)
Next
Next
Call Scrivi (sTitolo , True)
Call InitTabella ( aT ,RGB(239,239,239) )
Call AddRigaTabella (aV )
For k = 1 To nE
If CLng(aColoriCelle (k) )<> 0 Then
Call SetColoreCella (CInt(k+1) , aColoriCelle (k))
End If
Next
Call CreaTabella
End Sub
Sub MostraValoriUgualiTraLunghette (aValori1,aValori2 , sTitolo , sDescr )
Dim k , kk , i , b
Dim nE1 , nE2 , nQ
Dim aColori
Call Scrivi (sTitolo , True)
Call Scrivi ("Serie 1 : " & StringaNumeri(aValori1,,True))
Call Scrivi ("Serie 2 : " & StringaNumeri(aValori2 ,,True))
Call Scrivi
nE1 = UBound( aValori1 )
nE2 = UBound( aValori2 )
i =0
For k =1 To nE1
b = False
For kk = 1 To nE2
If aValori1(k) = aValori2(kk) Then
If b = False Then
b = True
Call Scrivi (sDescr & " : " & aValori1(k) , True)
i = i +1
End If
Call Scrivi ("Posizioni " & k & "-" & kk)
End If
Next
Next
If i = 0 Then Scrivi ("Nessuna")
End Sub
gli script non li faccio di solito .. ciao ...
