Lenteur exécution programme

Option Explicit
Public Sub ExtraireUT()
Dim dUT As Object
Dim dNw As Object
Dim wshRes As Worksheet
Dim tUT As Variant
Dim tdB As Variant
Dim tdH As Variant
Dim rng As Range
Dim i As Long

  Set wshRes = ThisWorkbook.Worksheets("resultat")
  ' Effacer les données précédentes
  With wshRes.UsedRange.Offset(1).EntireRow.Columns("D")
    .ClearContents
    With .Interior
      .Pattern = xlPatternNone
      .TintAndShade = 0
      .PatternTintAndShade = 0
    End With
  End With
  ' Liste des UT enregistrés
  Set dUT = CreateObject("Scripting.Dictionary")
  With wshRes
    tUT = Application.Transpose(.Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).Value)
    For i = LBound(tUT) To UBound(tUT)
      dUT(tUT(i)) = ""
    Next i
    Erase tUT
  End With
  ' Liste des nouveaux UT
  Set dNw = CreateObject("Scripting.Dictionary")
  Set rng = Workbooks("Données M.csv").Worksheets(1).UsedRange
  tdB = Application.Transpose(rng.Columns("B").Value)
  tdH = Application.Transpose(rng.Columns("H").Value)
  For i = LBound(tdB) + 1 To UBound(tdB)
    If tdB(i) = 404 And Left(CStr(tdH(i)), 1) <> "0" Then
      If Not dUT.Exists(tdH(i)) Then dNw(tdH(i)) = ""
    End If
  Next i
  Erase tdB
  Erase tdH
  ' Résultat
  If dNw.Count = 0 Then
    MsgBox ("Vous n'avez aucun nouvel UT")
  Else
    With wshRes
      With .Cells(2, "D").Resize(dNw.Count)
        .Value = Application.Transpose(dNw.Keys)
        .Interior.ColorIndex = 4
      End With
      With .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(dNw.Count)
        .Value = Application.Transpose(dNw.Keys)
        .NumberFormat = .Cells(1, 1).Offset(-1).NumberFormat
      End With
    End With
    MsgBox ("Vous avez " & dNw.Count & " nouveau(x) UT " & "Notez les N°")
  End If
End Sub

Option Explicit
Public Sub extraire()
Dim wshRes As Worksheet
Dim wshExt As Worksheet
Dim rng As Range
Dim cel As Range
Dim n°L As Long
Dim nUT As Long

  Set wshRes = ThisWorkbook.Worksheets("resultat")
  Set wshExt = ThisWorkbook.Worksheets("extraction")
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  ' Effacer les données précédentes
  wshExt.Cells.Clear
  With wshRes.UsedRange.Offset(1).EntireRow.Columns("D")
    .ClearContents
    With .Interior
      .Pattern = xlPatternNone
      .TintAndShade = 0
      .PatternTintAndShade = 0
    End With
  End With
  ' Copier les données
  Workbooks("Données M.csv").Worksheets(1).UsedRange.Copy wshExt.Range("A1")
  ' Traiter les données
  With wshExt
    ' Filtrer et supprimer <> 404
    With .Range("A1").CurrentRegion
      .AutoFilter
      .AutoFilter Field:=2, Criteria1:="<>404"
      .Offset(1).EntireRow.Delete
      .AutoFilter
    End With
    ' Supprimer colonnes
    .Range("A:A,B:B,I:J,M:M,Q:Q").Delete
    ' Filtrer et supprimer UT commence par 0 et =0
    With .Range("A1").CurrentRegion
      .AutoFilter
      .AutoFilter Field:=6, Criteria1:="=0*"
      .Offset(1).EntireRow.Delete
      .AutoFilter Field:=6, Criteria1:="=0"
      .Offset(1).EntireRow.Delete
      .AutoFilter
      .Offset(1).Columns("F").Copy wshRes.Range("D2")
    End With
  End With
  ' Ajouter les UT non enregistrés
  With wshRes
    Set rng = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
    rng.Interior.ColorIndex = xlNone
    n°L = .Cells(.Rows.Count, "D").End(xlUp).Row
    Do While n°L > 1
      Set cel = rng.Find(.Cells(n°L, "D").Value, , xlFormulas, xlWhole)
      If cel Is Nothing Then
        With rng.Offset(rng.Rows.Count).Cells(1, 1)
          .Value = wshRes.Cells(n°L, "D").Value
          .NumberFormat = .Offset(-1).NumberFormat
          .Interior.ColorIndex = 4
        End With
        .Cells(n°L, "D").Interior.ColorIndex = 4
        Set rng = rng.Resize(rng.Rows.Count + 1)
        nUT = nUT + 1
      End If
      n°L = n°L - 1
    Loop
  End With
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  If nUT = 0 Then
    MsgBox ("Vous n'avez aucun nouvel UT")
  Else
    MsgBox ("Vous avez " & nUT & " nouveau(x) UT " & "Notez les N°")
  End If
End Sub

Sub Test()
    ' remplacer la ligne de fin par la derniere ligne cellule colonne B non vide
    With Sheets("extraction")
        .Range("A1:C114").AutoFilter
        .Range("$A$1:$C$114").AutoFilter Field:=2, Criteria1:="<>404"
        .Range("A2:C114").EntireRow.Delete
        .Range("$A$1:$C$114").AutoFilter Field:=2
        'suppression colonnes
        .Range("A:A,B:B,I:J,M:M,Q:Q").Delete
    End With
End Sub