Peut-on optimiser ce code VBA ?

Option Explicit

Sub Test()
Dim w(1 To 2) As Worksheet, i%, Rg As Range, Nb&, Tb&(), j&, Rw&, T
    T = Now
    Application.ScreenUpdating = False
    Nb = WorksheetFunction.Combin(70, 2)
    Set w(1) = ActiveSheet
    Rw = w(1).Cells(Rows.Count, 3).End(xlUp).Row
    Sheets.Add
    Set w(2) = ActiveSheet
    For i = 1 To 2
        w(2).Cells(1, i) = i
    Next i
    w(2).Cells(2, 1).FormulaR1C1 = "=IF(R[-1]C[1]=70,R[-1]C+1,R[-1]C)"
    w(2).Cells(2, 2).FormulaR1C1 = "=IF(R[-1]C=70,RC[-1]+1,R[-1]C+1)"
    Set Rg = w(2).Range(w(2).Cells(2, 1), w(2).Cells(Nb, 2))
    w(2).Range(w(2).Cells(2, 1), w(2).Cells(2, 2)).AutoFill Destination:=Rg
    Rg.Copy: Rg.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ReDim Tb(1 To Nb)
    For i = 1 To Nb
        Tb(i) = 3
    Next i
    For i = Rw To 2 Step -1
        w(2).Cells(1, 3).FormulaR1C1 = "=COUNTIF(" & w(1).Name & "!R" & i & "C:R" & i & "C[19],RC[-2])+COUNTIF(" & w(1).Name & "!R" & i & "C:R" & i & "C[19],RC[-1])"
        Set Rg = w(2).Range(w(2).Cells(1, 3), w(2).Cells(Nb, 3))
        w(2).Cells(1, 3).AutoFill Destination:=Rg
        Rg.Copy: Rg.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        For j = 1 To Nb
            If w(2).Cells(j, 3) = 2 Then
                Tb(j) = Tb(j) + 1
                w(2).Cells(j, Tb(j)) = i - 1
            End If
        Next j
    Next i
    For i = 1 To Nb
        w(2).Cells(i, 3) = Tb(i) - 3
    Next i
    w(2).Rows(1).Insert Shift:=xlDown
    w(2).Cells(1, 1) = "n1": w(2).Cells(1, 2) = "n2": w(2).Cells(1, 3) = "qté"
    Application.ScreenUpdating = True
    With w(2).Cells
        .HorizontalAlignment = xlCenter
        .EntireColumn.AutoFit
    End With
    MsgBox (T - Now) * 86400
End Sub

Option Explicit

Sub Binome()

Const Nb = (70 * 70 - 70) / 2
Dim i, j, k, l, m
Dim Vals, DerLig
Dim Bin1(Nb), Bin2(Nb), BinNbr(Nb), BinTirage(Nb)
Dim OK, T1

Sheets("Trié").Activate
Range("X:XFD").ClearContents

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
T1 = Timer
'lecture tirage
DerLig = 30
DerLig = Application.InputBox(prompt:="Nombre de tirage à prendre en compte ( 0=tout) ?", Default:=30, Type:=1)
If DerLig = 0 Then
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
Else
    DerLig = DerLig + 1
End If

Vals = Range("C2:V2").Resize(DerLig - 1)

'remplissage binome de numéros
For i = 1 To 70
    For j = i + 1 To 70
        m = m + 1
        Bin1(m) = i: Bin2(m) = j
    Next j
Next i

'boucle comptage
For m = 1 To Nb
    For i = 1 To DerLig - 1
        OK = 0
        'recherche du 1ier nombre
        For j = 1 To 20
            If Vals(i, j) = Bin1(m) Then Exit For
        Next j
        If j < 21 Then
            For k = j + 1 To 20
                If Vals(i, k) = Bin2(m) Then
                    BinNbr(m) = BinNbr(m) + 1
                    BinTirage(m) = i & " " & BinTirage(m)
                    Exit For
                End If
            Next k
        End If
    Next i
Next m
            
'écriture des résultats
Const ColBase = "X"
Dim NcolBase, TT
NcolBase = Range(ColBase & 1).Column

For m = 1 To Nb
    Cells(m + 1, NcolBase) = Bin1(m) & "," & Bin2(m)
    Cells(m + 1, NcolBase).Offset(, 1) = BinNbr(m)
    If BinNbr(m) >= 1 Then
        TT = Split(BinTirage(m))
        Cells(m + 1, NcolBase).Offset(, 2).Resize(, UBound(TT) - LBound(TT) + 1) = TT
    End If
Next m

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox Timer - T1
End Sub


Function UnTirage()
Dim TT(1 To 20), NN(70), n, aux, i

For i = 1 To 70: NN(i) = i: Next i

For i = 1 To 20
    n = Application.WorksheetFunction.RandBetween(i, 70)
    TT(i) = NN(n)
    aux = NN(i)
    NN(i) = NN(n)
    NN(n) = aux
Next i
UnTirage = TT

End Function

Sub NNN_tirage()
Dim i
Dim T1

T1 = Timer
Sheets("Feuil1").Activate
Range("C2:V7001").ClearContents
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 2 To 7001
Cells(i, 3).Resize(, 20) = UnTirage
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox Timer - T1

End Sub

Sheets("Trié").Activate

Sheets("Feuil1").Activate