Ralentissement de l'exécution d'une macro [Résolu/Fermé]

Bonjours à tous!

J'ai un problème avec une macro que j'utilise pour faire un tri mes données et les copie dans une autres feuilles selon leur type. La macro fonctionnais très bien et rapidement avec ma feuille test mais dès que je la vide et que je recommence à zéro avec de nouvelles données c'est très lent.

Je n'y comprend rien!

La macro se lance avec le bouton mettre à jours les feuillets sur la page "Accueil" et lorsque j'ouvre la fichier si la cellule "A5" est non vide.

Voici mon code principale:

Sub CopieFeuillets()
' Macro de Copie & de Tri

Dim f As Worksheet

Application.ScreenUpdating = False

For Each f In ActiveWorkbook.Worksheets
    f.Unprotect
Next

   With Sheets("Coordonnées")
  
        For i = 1 To 4
            On Error Resume Next
            Erase critères
            On Error GoTo 0
            Select Case i
            
            Case 1
                wsn = "FORAGE"
                critères = Array("F", "FC", "FS", "FSZ")
                Col = "A" ' colonne dans laquelle mettre le n° de sondage, est également la colonne pour le tri
               PL = 8 'première ligne des données dans wsn
               tabtri = "A" & PL & ":N" ' tableau à trier
           Case 2
                wsn = "CPTU"
                critères = Array("C", "CR", "FC", "M")
                Col = "A"
                PL = 7
                tabtri = "A" & PL & ":O"
            Case 3
                wsn = "Piézomètres"
                critères = Array("Z", "FSZ")
                Col = "B"
                PL = 8
                tabtri = "A" & PL & ":M"
            Case 4
                wsn = "Inclinomètres"
                critères = Array("I")
                Col = "B"
                PL = 7
                tabtri = "A" & PL & ":H"
            End Select
           
            .Range("$A$4:$N$64").AutoFilter Field:=4, Criteria1:=critères, Operator:=xlFilterValues         'on filtre les données de coordonnées
           
           Set ws = Sheets(wsn)    ' ws = référence de la feuille
           nl = ws.Cells(Rows.Count, Col).End(xlUp).Row    ' nl pointeur de dernière ligne utilisée dans la feuille basé sur colonne col
           If nl < PL Then nl = PL + 1
            For Each r In .Range(.Range("C5"), .Range("C5").End(xlDown)).SpecialCells(xlVisible)    ' on parcourt toutes les cellules sélectionnées de la colonne  C, (r=cellule en cours)
               Set re = ws.Range(Col & ":" & Col).Find(r.Value, lookat:=xlWhole)    'on recherche le n°de sondage dans la colonne col
               If re Is Nothing Then    'si non trouvé
                    'ajoute une nouvelle ligne avant derniere ligne
                    ws.Rows(nl).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    'derniere ligne + 1
                    ws.Cells(nl, Col) = ws.Cells(nl - 1, Col)
                    ws.Cells(nl - 1, Col) = r.Value  ' on met le numéro de sondage en colonne col
               End If
            Next
            With ws.Range(tabtri & nl)
                .Sort key1:=.Cells(1, Col), order1:=xlAscending, Header:=xlNo
            End With
        Next i
        If Worksheets("Coordonnées").AutoFilterMode Then
            Worksheets("Coordonnées").AutoFilterMode = False
        End If
    End With
    

For Each f In ActiveWorkbook.Worksheets
    f.Protect
Next
    
Application.EnableEvents = True

End Sub

J'ai aussi une macro sur ma feuille destination:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim T As Range, i&
Set T = [Tableau5]
Application.EnableEvents = False
On Error Resume Next 'sécurité
If T.Rows.Count < 4 Then
  Application.Undo 'annulation
Else
  '---suppression des lignes vides---
  For i = T.Rows.Count - 1 To 4 Step -1
    If T(i, 1) = "" Then T(i, 1).EntireRow.Delete
  Next
  '---ajout de ligne---
  If T(T.Rows.Count, 1) <> "" Then
    Application.ScreenUpdating = False
    T(T.Rows.Count, 1).EntireRow.Insert
    T.Rows(T.Rows.Count - 1).FormulaR1C1 = T.Rows(T.Rows.Count).FormulaR1C1
    T.Rows(T.Rows.Count) = ""
    Application.ScreenUpdating = True
  End If
End If

End Sub

Pouvez-vous m'aider?

Je joint aussi mon fichier: http://cjoint.com/?0Eird3REtmw

Merci!