[RISOLTO] Velocizzare elaborazione VBA

Option Explicit

Sub Crea_Ambi()
Dim iTime1 As Single, iTime2 As Single, fTime1 As Single, fTime2 As Single, nRig As Long
Dim estr, ambo()
Dim i As Long, j As Long, k As Long, a As Long, rg As Long
Dim Dic, tempArr, key
iTime1 = Timer
Range("J:L, N2:N3").ClearContents
nRig = Cells(1, 9).Value
If nRig = 0 Then nRig = Cells(Rows.Count, 2).End(xlUp).Row
Cells(1, 10) = "freq.": Cells(1, 11) = "A1": Cells(1, 12) = "A2"
'assume la sestina di ogni riga
estr = Range("B2:G" & nRig) 'Cells(Rows.Count, 7).End(xlUp).Row).Value
ReDim ambo(1 To UBound(estr) * 15)
Set Dic = CreateObject("Scripting.Dictionary")
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For i = LBound(estr) To UBound(estr)
    For j = 1 To 5
      For k = j + 1 To 6
        a = a + 1
        ambo(a) = estr(i, j) & "," & estr(i, k)
        If Not .Exists(Dic.Item(ambo(a))) Then
          Dic.Item(ambo(a)) = ambo(a)
        End If
      Next k
    Next j
  Next i
End With
fTime1 = Timer
Cells(2, "N") = fTime1 - iTime1
'
iTime2 = Timer
rg = 2
For Each key In Dic.Keys
  tempArr = Split(key, ",")
  For i = 1 To UBound(ambo)
    If key = ambo(i) Then Cells(rg, 10) = Cells(rg, 10) + 1
  Next i
  For i = 0 To 1
    Cells(rg, i + 11) = CInt(tempArr(i))
  Next i
  rg = rg + 1
Next key
fTime2 = Timer
Cells(3, "N") = fTime2 - iTime2
Set Dic = Nothing
Cells(1, 1).Select
End Sub

Option Explicit

Sub RMatr()

   Dim ArrAmbi As Variant
   Dim arrEstrazioni As Variant
   Dim i As Long, j As Long, t As Long, y As Long
   Dim contaAmbi As Long
   Dim v1 As Long
   Dim v2 As Long
   Dim v3 As Long
   Dim v4 As Long
   
   Dim dTimer As Double
   
   Range("C2:C5000").ClearContents
   dTimer = Timer
   ArrAmbi = Range("A2:C4015")
   arrEstrazioni = Range("E2:J3724")

   For i = 1 To UBound(ArrAmbi, 1)
      v1 = ArrAmbi(i, 1)
      v2 = ArrAmbi(i, 2)
      For t = 1 To UBound(arrEstrazioni, 2) - 1
         For j = 1 To UBound(arrEstrazioni, 1)
            v3 = arrEstrazioni(j, t)
            If v3 = v1 Then
               For y = t + 1 To UBound(arrEstrazioni, 2)
                  v4 = arrEstrazioni(j, y)
                  If v4 = v2 Then
                     contaAmbi = contaAmbi + 1
                  End If
               Next y
            End If
         Next j
      Next t
      ArrAmbi(i, 3) = contaAmbi
      contaAmbi = 0
   Next i
   Range("A2").Resize(UBound(ArrAmbi), 3) = ArrAmbi
   MsgBox "Uso Tabelle secondi = " & Timer - dTimer
End Sub

Sub AmbiMatrix() 'by Marius44
Dim ArrAmbi As Variant, ArrEstr As Variant
Dim sTime As Single
Dim i As Long, j As Long, t As Long, y As Long, contaAmbi As Long
Dim a1 As Integer, a2 As Integer
  Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row).ClearContents 'cancella frequenze
  sTime = Timer 'avvia timer
  ArrAmbi = Worksheets("Sal").ListObjects("Tabella1").DataBodyRange.Value
  ArrEstr = Worksheets("Sal").ListObjects("Tabella2").DataBodyRange.Value
  For i = 1 To UBound(ArrAmbi, 1)
    a1 = ArrAmbi(i, 1)  'primo numero riga della tabella ambi
    a2 = ArrAmbi(i, 2)  'secondo numero riga della tabella ambi
    For t = 1 To UBound(ArrEstr, 2) - 1
      For j = 1 To UBound(ArrEstr, 1)
        If ArrEstr(j, t) = a1 Then 'se uguale al numero estratto
          For y = t + 1 To UBound(ArrEstr, 2)
            If ArrEstr(j, y) = a2 Then
              contaAmbi = contaAmbi + 1
            End If
          Next y
        End If
      Next j
    Next t
    ArrAmbi(i, 3) = contaAmbi
    contaAmbi = 0
  Next i
  Worksheets("Sal").ListObjects("Tabella1").DataBodyRange.Value = ArrAmbi
  Cells(4, 12) = Timer - sTime
  MsgBox "Uso Tabelle secondi = " & Timer - sTime
'
End Sub