Moderatori: Anthony47, Flash30005
Sub conta2()
Dim Start As Range, cCount As Range, reCnt As Long, myTim As Single
Dim wArr, rArr, I As Long, J As Long, lCnt As Long, K As Long, taPun As Long
'
Set Start = Sheets("FoglioA").Range("A2") '<<< La cella di inizio della Tabella
Set cCount = Sheets("FoglioA").Range("G1") '<<< La cella dei risultati
taPun = 2 '<<< I punti da raggiungere
'
myTim = Timer
wArr = Start.CurrentRegion.Value
For I = 1 To UBound(wArr) - 1
rArr = Application.WorksheetFunction.Index(wArr, I, 0)
For J = I + 1 To UBound(wArr)
lCnt = 0
For K = 1 To 5
If Not IsError(Application.Match(wArr(J, K), rArr, 0)) Then
lCnt = lCnt + 1
End If
If lCnt = taPun Then
reCnt = reCnt + 1
Debug.Print I, J, K
' lCnt = 0
Exit For
End If
Next K
Next J
Next I
cCount.Value = reCnt
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
wArr = Range(Start, Start.End(xlDown)).Resize(, 5).Value
quando hai tempo ci sarebbe da sistemare quante ne trova con 2 punti
ma l'analisi va fatte su tutte di ogni cinquina.
Vedo di darti uno spunto cosi puoi lavorare sul certo.
dopo = trovi che quella cinquina ha altri con 2 punti
Sub conta2()
Dim Start As Range, cCount As Range, reCnt As Long, myTim As Single
Dim wArr, rArr, I As Long, J As Long, lCnt As Long, K As Long, taPun As Long
'
Set Start = Sheets("FoglioA").Range("A2") '<<< La cella di inizio della Tabella
Set cCount = Sheets("FoglioA").Range("G2") '<<< La cella di inizio dei risultati
taPun = 2 '<<< I punti da raggiungere
'
myTim = Timer
wArr = Range(Start, Start.End(xlDown)).Resize(, 5).Value
cCount.Resize(UBound(wArr) + 5, 1).ClearContents 'Azzera area dei risultati
For I = 1 To UBound(wArr)
rArr = Application.WorksheetFunction.Index(wArr, I, 0)
For J = 1 To UBound(wArr)
If I <> J Then
lCnt = 0
For K = 1 To 5
If Not IsError(Application.Match(wArr(J, K), rArr, 0)) Then
lCnt = lCnt + 1
End If
If lCnt = taPun Then
reCnt = reCnt + 1
' Debug.Print I, J, K
Exit For
End If
Next K
End If
Next J
cCount.Cells(I, 1) = reCnt
reCnt = 0
Next I
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Sub conta23()
Dim Start As Range, cCount As Range, reCnt As Long, myTim As Single
Dim wArr, rArr, I As Long, J As Long, lCnt As Long, K As Long, taPun As Long
'
Set Start = Sheets("FoglioA").Range("A2") '<<< La cella di inizio della Tabella
Set cCount = Sheets("FoglioA").Range("G2") '<<< La cella di inizio dei risultati
''taPun = 2 '<<< I punti da raggiungere
'
myTim = Timer
'wArr = Start.CurrentRegion.Value
wArr = Range(Start, Start.End(xlDown)).Resize(, 5).Value
cCount.Resize(UBound(wArr) + 5, 1).ClearContents 'Azzera area dei risultati
For I = 1 To UBound(wArr)
rArr = Application.WorksheetFunction.Index(wArr, I, 0)
For J = 1 To UBound(wArr)
If I <> J Then
lCnt = 0
For K = 1 To 5
If Not IsError(Application.Match(wArr(J, K), rArr, 0)) Then
lCnt = lCnt + 1
End If
Next K
If lCnt = 2 Then
reCnt = reCnt + 1
ElseIf lCnt > 2 Then
reCnt = reCnt + 3
End If
End If
Next J
cCount.Cells(I, 1) = reCnt
reCnt = 0
Next I
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Questa non l'ho capita ma ho capito che la proposta appena fatta va bene, se funzionaAl contrario se più sbrigativo porti a 3 numeri .
giorgioa ha scritto:https://1drv.ms/x/s!AoUgxEWS5dZ8gTSqw0Nac-dRRDtT?e=3zQMDo
Tutto e' bene quel che finisce benissimoHo provato il Punti23 e va benissimo
Mi ritengo soddisfattissimo.
E' che, lavorando coi numeri, so che certi calcoli non portano a niente di utile.So che non sei interessato ma il lavoro che mi hai fatto è perchè lavoro su frequenze
prendendo in considerazione le prime 10 cinquine e facendo degli scarti.
Torna a Applicazioni Office Windows
Confronto Tra due serie di punti Autore: Francesco6918 |
Forum: Applicazioni Office Windows Risposte: 16 |
Esclusione Punti Da Una Tabella Autore: Francesco6918 |
Forum: Applicazioni Office Windows Risposte: 5 |
Excel 2010 Inserire righe in punti variabili Autore: fasa |
Forum: Applicazioni Office Windows Risposte: 14 |
Visitano il forum: Nessuno e 12 ospiti