accélérer le code

[jad73]

bonjour le forum

j'ai un code qui met entre 5 et 6 minutes pour s'exécuter.
Y aurait-il la possibilité de l'accélérer.
je joint le code et le fichier.
merci

Sub Combinaison()
Worksheets("Feuil1").Select
Dim I As Long, K As Long, M As Long, N As Long
Dim NbMax As Long
Dim Tablo(1 To 70, 1 To 70, 1 To 70, 1 To 70) As Long
Dim J As Long
Dim Resultat(1 To 1, 1 To 5)
Dim Tbl1
Dim Nombre As Long

  Application.ScreenUpdating = False
  Tbl1 = Range("BdD")
  NbMax = UBound(Tbl1, 2)
  
  For J = 1 To UBound(Tbl1)
    For I = 1 To NbMax - 3
      For K = I + 1 To NbMax - 2
        For M = K + 1 To NbMax - 1
          For N = M + 1 To NbMax
          Tablo(Tbl1(J, I), Tbl1(J, K), Tbl1(J, M), Tbl1(J, N)) = Tablo(Tbl1(J, I), Tbl1(J, K), Tbl1(J, M), Tbl1(J, N)) + 1
          Next N
        Next M
      Next K
    Next I
  Next J
  
  For Nombre = 1 To 70
  Resultat(1, 5) = 0
    For I = 1 To 70
      For K = 1 To 70
        For M = 1 To 70
          For N = 1 To 70
          If I = Nombre Or K = Nombre Or M = Nombre Or N = Nombre Then
            If Tablo(I, K, M, N) > Resultat(1, 5) Then
              Resultat(1, 1) = I
              Resultat(1, 2) = K
              Resultat(1, 3) = M
              Resultat(1, 4) = N
              Resultat(1, 5) = Tablo(I, K, M, N)
              End If
            End If
          Next N
        Next M
      Next K
    Next I
    Cells(1 + Nombre, "X").Resize(1, 5) = Resultat
  Next Nombre
End Sub