[RISOLTO] Velocizzare elaborazione VBA

Sub ContaAmbi() 'byAnthony47 - pulsante 4
Dim oArr(1 To 4005, 1 To 3), iArr(1 To 90, 1 To 90) As Integer, iInd As Integer
Dim wArr, rArr, i As Long, j As Long, K As Long, a As Long
Dim dSh As Worksheet, oSh As Worksheet, dePos As Range
Dim iTime As Single
'
Set dSh = Sheets("Foglio2")
Set oSh = Sheets("Foglio1")
Set dePos = oSh.Range("P3")             '<<< La posizione di output
'
dePos.Resize(4005, 3).ClearContents
iTime = Timer
wArr = Range(dSh.Range("B2"), dSh.Range("B2").End(xlDown).Offset(0, 5)).Value
'crea 4005 ambi canonici e pointer
For i = 1 To 89
  For j = i + 1 To 90
    a = a + 1
    oArr(a, 1) = i: oArr(a, 2) = j
    iInd = iInd + 1
    iArr(i, j) = iInd
  Next j
Next i
'inizia ciclo ricerca-confronto ambi
For i = 1 To UBound(wArr)
  For j = 1 To 5
    For K = j + 1 To 6
      oArr(iArr(wArr(i, j), wArr(i, K)), 3) = oArr(iArr(wArr(i, j), wArr(i, K)), 3) + 1
    Next K
  Next j
Next i
'
dePos.Resize(4005, 3) = oArr
dePos.Offset(-1, 3) = (Timer - iTime)
Set dSh = Nothing
Set oSh = Nothing
Set dePos = Nothing
End Sub

=SE.ERRORE(INDICE(P$3:P$10000;AGGREGA(15;6;RIF.RIGA($1:$10000)/($R$3:$R$10000=MODA($R$3:$R$10000));RIF.RIGA(A1)));"")

=FILTRO($P$3:$Q$10000;$R$3:$R$10000=MODA($R$3:$R$10000);"")

....
'inizia ciclo ricerca-confronto ambi
For i = 1 To UBound(wArr)
  For j = 1 To 5
    For K = j + 1 To 6
      oArr(iArr(wArr(i, j), wArr(i, K)), 3) = oArr(iArr(wArr(i, j), wArr(i, K)), 3) + 1
    Next K
  Next j
Next i
....

'crea 4005 ambi canonici e pointer
For i = 1 To 89
  For j = i + 1 To 90
    a = a + 1
    oArr(a, 1) = i: oArr(a, 2) = j
    iInd = iInd + 1
    iArr(i, j) = iInd
  Next j
Next i

Option Explicit

'prova terni
Sub ContaTerni() 'byAnthony47 revisione Marius44
Dim oArr(1 To 117480, 1 To 4), iArr(1 To 90, 1 To 90, 1 To 90) As Long, iInd As Long
Dim wArr, rArr, i As Long, j As Long, k As Long, a As Long, h As Long
Dim dSh As Worksheet, oSh As Worksheet, dePos As Range
Dim iTime As Single
'
Set dSh = Sheets("Foglio2")
Set oSh = Sheets("Foglio1")
Set dePos = oSh.Range("U3")             '<<< La posizione di output
'
dePos.Resize(117480, 4).ClearContents
iTime = Timer
wArr = Range(dSh.Range("B2"), dSh.Range("B2").End(xlDown).Offset(0, 5)).Value
'crea 125580 ternii canonici e pointer
For i = 1 To 88
  For j = i + 1 To 89
    For k = j + 1 To 90
      a = a + 1
      oArr(a, 1) = i: oArr(a, 2) = j: oArr(a, 3) = k
      iInd = iInd + 1
      iArr(i, j, k) = iInd
    Next k
  Next j
Next i
'
'inizia ciclo ricerca-confronto terni
For i = 1 To UBound(wArr)
  For j = 1 To 4
    For k = j + 1 To 5
      For h = k + 1 To 6
        oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) = oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) + 1
      Next h
    Next k
  Next j
Next i
'
dePos.Resize(117480, 4) = oArr
dePos.Offset(-1, 4) = (Timer - iTime)
Set dSh = Nothing
Set oSh = Nothing
Set dePos = Nothing
End Sub

'inizia ciclo ricerca-confronto ambi
For i = 1 To UBound(wArr)
  For j = 1 To 5
    For K = j + 1 To 6
      oArr(iArr(wArr(i, j), wArr(i, K)), 3) = oArr(iArr(wArr(i, j), wArr(i, K)), 3) + 1
    Next K
  Next j
Next i

'prova terni per il Lotto

'supponiamo che le estrazioni del lotto siano
'le colonne dalla B alla F comprese di Foglio2

Sub ContaTerniLotto()
Dim oArr(1 To 117480, 1 To 4), iArr(1 To 90, 1 To 90, 1 To 90) As Long, iInd As Long
Dim wArr, rArr, i As Long, j As Long, k As Long, a As Long, h As Long
Dim dSh As Worksheet, oSh As Worksheet, dePos As Range
Dim iTime As Single
'
Set dSh = Sheets("Foglio2")
Set oSh = Sheets("Foglio1")
Set dePos = oSh.Range("AA3")             '<<< La posizione di output
'
dePos.Resize(117480, 4).ClearContents
iTime = Timer
wArr = Range(dSh.Range("B2"), dSh.Range("B2").End(xlDown).Offset(0, 4)).Value
'crea 117480 ternii canonici e pointer
For i = 1 To 88
  For j = i + 1 To 89
    For k = j + 1 To 90
      a = a + 1
      oArr(a, 1) = i: oArr(a, 2) = j: oArr(a, 3) = k
      iInd = iInd + 1
      iArr(i, j, k) = iInd
    Next k
  Next j
Next i
'
'inizia ciclo ricerca-confronto terni
For i = 1 To UBound(wArr)
  For j = 1 To 3
    For k = j + 1 To 4
      For h = k + 1 To 5
        oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) = oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) + 1
      Next h
    Next k
  Next j
Next i
'
dePos.Resize(117480, 4) = oArr
dePos.Offset(-1, 4) = (Timer - iTime)
Set dSh = Nothing
Set oSh = Nothing
Set dePos = Nothing
End Sub

Sub Leo_2()
Dim oArr(1 To 26235, 1 To 4), iArr(1 To 55, 1 To 55, 1 To 55) As Long, iInd As Long
Dim wArr, rArr, i As Long, j As Long, k As Long, a As Long, h As Long
Dim dSh As Worksheet, oSh As Worksheet, dePos As Range
Dim iTime As Single

Set oSh = Sheets("Foglio1")
Set dePos = oSh.Range("P1")             '<<< La posizione di output
'
dePos.Resize(26235, 4).ClearContents
iTime = Timer
wArr = Range(oSh.Range("J1"), oSh.Range("J1").End(xlDown).Offset(0, 5)).Value

'crea 26235 terni canonici e pointer
For i = 1 To 53
  For j = i + 1 To 54
    For k = j + 1 To 55
      a = a + 1
      oArr(a, 1) = i: oArr(a, 2) = j: oArr(a, 3) = k
      iInd = iInd + 1
      iArr(i, j, k) = iInd
    Next k
  Next j
Next i
'inizia ciclo ricerca-confronto terni
For i = 1 To UBound(wArr)
  For j = 1 To 3
    For k = j + 1 To 4
      For h = k + 1 To 5
        oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) = oArr(iArr(wArr(i, j), wArr(i, k), wArr(i, h)), 4) + 1
      Next h
    Next k
  Next j
Next i

dePos.Resize(26235, 4) = oArr
dePos.Offset(0, 5) = (Timer - iTime)
Set oSh = Nothing
Set dePos = Nothing
End Sub

Terno(indice(archivio(i, j), archivio(i, k), archivio(i, h)), 4) = Terno(indice(archivio(i, j), archivio(i, k), archivio(i, h)), 4) + 1

x = indice(archivio(i, j), archivio(i, k), archivio(i, h))
Terno(x, 4) = Terno(x, 4) + 1

Sub Leo_2()
Dim Terno(1 To 26235, 1 To 4), indice(1 To 55, 1 To 55, 1 To 55) As Long
Dim archivio, i As Long, j As Long, k As Long, a As Long, h As Long, x As Long
Dim oSh As Worksheet, dePos As Range
Dim iTime As Single, it As Single

Set oSh = Sheets("Foglio1")
Set dePos = oSh.Range("P1")             '<<< La posizione di output

dePos.Resize(26235, 4).ClearContents
archivio = Range(oSh.Range("A1"), oSh.Range("A1").End(xlDown).Offset(0, 5)).Value

'crea 26235 terni canonici e pointer
For i = 1 To 53
  For j = i + 1 To 54
    For k = j + 1 To 55
      a = a + 1
      Terno(a, 1) = i: Terno(a, 2) = j: Terno(a, 3) = k
      indice(i, j, k) = a
    Next k
  Next j
Next i

'ciclo ricerca-confronto terni
iTime = Timer
For i = 1 To UBound(archivio)
  For j = 1 To 3
    For k = j + 1 To 4
      For h = k + 1 To 5
      x = indice(archivio(i, j), archivio(i, k), archivio(i, h))
      Terno(x, 4) = Terno(x, 4) + 1
      Next h
    Next k
  Next j
Next i

it = Timer - iTime
dePos.Resize(26235, 4) = Terno
dePos.Offset(0, 5) = it
Set oSh = Nothing
Set dePos = Nothing
End Sub

Option Explicit

Sub Unica()
Dim Terno(1 To 117480, 1 To 4) As Long, indice(1 To 88, 1 To 89, 1 To 90) As Long
Dim i As Long, j As Integer, k As Integer, h As Integer
Dim a As Long, b As Long, x As Long
Dim archivio, MAIUSCITI(1 To 117480, 1 To 3), ESTRATTI(1 To 117480, 1 To 4)
Dim iT1 As Single, fT1 As Single

Range("K2:R117481,I12:I15").ClearContents
iT1 = Timer
'crea 117480 terni canonici e pointer
For i = 1 To 88
  For j = i + 1 To 89
    For k = j + 1 To 90
      a = a + 1
      Terno(a, 1) = i: Terno(a, 2) = j: Terno(a, 3) = k: Terno(a, 4) = 0
      indice(i, j, k) = a
    Next k
  Next j
Next i
fT1 = Timer
Cells(12, 9) = fT1 - iT1
iT1 = Timer
archivio = Range(Range("A2"), Range("A2").End(xlDown).Offset(0, 5)).Value
For i = 1 To UBound(archivio)
  For j = 1 To 4
    For k = j + 1 To 5
      For h = k + 1 To 6
        'velocizzazione by Leo
        x = indice(archivio(i, j), archivio(i, k), archivio(i, h))
        Terno(x, 4) = Terno(x, 4) + 1
      Next h
    Next k
  Next j
Next i
fT1 = Timer
Cells(13, 9) = fT1 - iT1
iT1 = Timer
a = 0: b = 0
For i = 1 To UBound(Terno)
  If Terno(i, 4) = 0 Then
    a = a + 1
    MAIUSCITI(a, 1) = Terno(i, 1)
    MAIUSCITI(a, 2) = Terno(i, 2)
    MAIUSCITI(a, 3) = Terno(i, 3)
  ElseIf Terno(i, 4) > 0 Then
    b = b + 1
    ESTRATTI(b, 1) = Terno(i, 1)
    ESTRATTI(b, 2) = Terno(i, 2)
    ESTRATTI(b, 3) = Terno(i, 3)
    ESTRATTI(b, 4) = Terno(i, 4)
  End If
Next i
fT1 = Timer
Cells(14, 9) = fT1 - iT1
iT1 = Timer
Cells(2, 11).Resize(UBound(ESTRATTI), 4) = ESTRATTI
Cells(2, 16).Resize(UBound(ESTRATTI), 3) = MAIUSCITI
fT1 = Timer
Cells(15, 9) = fT1 - iT1
End Sub

Option Explicit

Sub Estratti_NonEstratti() 'commentata
Dim indice(1 To 88, 1 To 89, 1 To 90, 99) As Long
Dim archivio, i As Long, j As Long, k As Long, a As Long, h As Long
Dim oSh As Worksheet, dePos As Range
Dim iTime As Single, it As Single, ft As Single

Set oSh = Sheets("Foglio2")             'Foglio in cui sono i dati d'archivio
Set dePos = oSh.Range("K1")             'posizione di output

'cancella precedenti
Range("I12:I15,K:R").ClearContents

Application.ScreenUpdating = False      'evita aggiornamento schermo
iTime = Timer                           'start tempo
'assegna a matrice i valori dell'archivio
archivio = Range(oSh.Range("A2"), oSh.Range("A2").End(xlDown).Offset(0, 5)).Value
'assegna alla matrice "indice" un determinato terno e la sua frequenza
For i = 1 To UBound(archivio)
  For j = 1 To 4
    For k = j + 1 To 5
      For h = k + 1 To 6
        indice(archivio(i, j), archivio(i, k), archivio(i, h), 4) = indice(archivio(i, j), archivio(i, k), archivio(i, h), 4) + 1
      Next h
    Next k
  Next j
Next i
Cells(12, 9) = Timer - iTime               'tempo impiegato parte 1
'visualizzazione provvisoria by Leo-Marius
iTime = Timer
Dim ur As Long, nt As Long
nt = UBound(archivio) * 20
ReDim scrivi(1 To nt, 1 To 4)
a = 0
For i = 99 To 1 Step -1
  For j = 1 To 88
    For k = j + 1 To 89
      For h = k + 1 To 90
        If indice(j, k, h, 4) = i Then
          a = a + 1
          scrivi(a, 1) = j: scrivi(a, 2) = k: scrivi(a, 3) = h: scrivi(a, 4) = i
        End If
      Next
    Next
  Next
Next
Cells(13, 9) = Timer - iTime
iTime = Timer
'elenco terni MAI usciti rispetto a quelli canonici(117480)
Dim b As Long, dePos2 As Range
Set dePos2 = oSh.Range("O1")
ReDim NoTerno(1 To 117480 - a, 4)
  For j = 1 To 88
    For k = j + 1 To 89
      For h = k + 1 To 90
        If indice(j, k, h, 4) = 0 Then
          b = b + 1
          NoTerno(b, 1) = j: NoTerno(b, 2) = k: NoTerno(b, 3) = h: NoTerno(b, 4) = 0
        End If
      Next
    Next
  Next
Cells(14, 9) = Timer - iTime
Application.ScreenUpdating = True         'ripristina aggiornamento schermo
iTime = Timer
dePos.Resize(a, 4) = scrivi               'riporta i dati dalla matrice al foglio
dePos2.Resize(b, 4) = NoTerno             'riporta i dati dalla matrice al foglio
Cells(15, 9) = Timer - iTime
Set oSh = Nothing
Set dePos = Nothing
Set dePos2 = Nothing
End Sub