Optimisation boucle vba

Bonjour tous le monde,

A l'aide,

Je dois rendre un travail la semaine prochaine.

En effet, je boucle sur plus de 95565 lignes, avec bien entendu des calculs entre temps.

Mon problème est que mon code n'est pas optimisé.
Je vous mets le code, si vous pouvez m'aidez

Sub correspondance_abc_passage_LSCO()
Application.ScreenUpdating = False

  'filtre données base abc sur scolaire pour diminuer le nombre de lignes sur lesquelles boucler.
  Call remonte_sco_abc
  Call remonte_sco_passage

l = Sheets("abc").Range("A3").End(xlDown).Row
 Sheets("abc").Range("AA3:AA" & l).ClearContents
array1 = Sheets("abc").Range("G3:AA" & l).Value
ll = Sheets("passage").Range("A4").End(xlDown).Row
array2 = Sheets("passage").Range("P4:Q" & ll).Value

 For i = LBound(array1) To UBound(array1)
   'condtion pour continuer le traitement c'est à dire il faut avoir du scolaire
  If array1(i, 1) = "SCOLAIRE" Then
    j = 1
     Do
      If array1(i, 20) = array2(j, 1) Then
         array1(i, 21) = "trouvee"
      Exit Do
      End If
      j = j + 1
    Loop Until array2(j, 2) <> "SCOLAIRE"
    If array1(i, 21) <> "trouvee" Then
        array1(i, 21) = "non trouvee"
    End If
 Else
 Exit For
 End If
 Next
 ' à la sortie ici j'aura fini les scolaires.
Sheets("abc").Range("G3:AA" & l).Value = array1
'j 'appel ensuite la fonction qui permet de faire le même traitement pour les lignes régulières.
Call correspondance_abc_passage_LREG
Application.ScreenUpdating = True
End Sub

Ci joint également le code correspondant à correspondance_abc_passage_LREG

Sub correspondance_abc_passage_LREG()
Application.ScreenUpdating = False

  'filtre données base abc sur scolaire pour aller plus vite
  Call remonte_reg_abc
  Call remonte_reg_passage
l = Sheets("abc").Range("A3").End(xlDown).Row
array1 = Sheets("abc").Range("G3:AA" & l).Value
ll = Sheets("passage").Range("A4").End(xlDown).Row
array2 = Sheets("passage").Range("P4:Q" & ll).Value

 For i = LBound(array1) To UBound(array1)
   'condtion pour continuer le traitement c'est à dire il faut avoir du scolaire
 
  If array1(i, 1) = "LIGNE REG" Then
    j = 1
     Do
      If array1(i, 20) = array2(j, 1) Then
         array1(i, 21) = "trouvee"
      Exit Do
      End If
      j = j + 1
    Loop Until array2(j, 2) <> "LIGNE REG"
    If array1(i, 21) <> "trouvee" Then
        array1(i, 21) = "non trouvee"
    End If
 Else
 Exit For
 End If
 Next
Sheets("abc").Range("G3:AA" & l).Value = array1
Application.ScreenUpdating = True
End Sub

Je vous remercie d'avance pour votre aide.
BARRY