Peut on améliorer mon code pour qu'il soit plus rapide

Sub Suivi_des_PO()
Dim i%
Dim j As Range
Dim l As Range
Dim c As Range
Dim r As Range
Dim d As Range
Dim e As Range
Dim f As Range
Dim Départ As String
Dim Somme&

With Worksheets("TradeCard")
Application.ScreenUpdating = False
Set l = .Range("D65536").End(xlUp)
Do While l.Row > 1
If InStr(l, "M") <> 1 Then
    l.EntireRow.Delete
    Set l = .Range("D65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop
.Columns(5).Insert
.Cells(1, 5) = "PO-LG"
Set f = .Range("E2")
Do While f.Offset(0, -1) <> ""
    f = Split(f(1, 0), "/")(0) & "-" & Mid(.Range("G" & f.Row).Value, 4, 3)
    Set f = f.Offset(1, 0)
Loop

End With

'supprime les colonnes de A,B,D,E,F,G,H,M,S,U,V,W
With Worksheets("5-9-12")
.Range("A:B,D:D,J:K,M:M,S:S,U:W").Delete

'supprime toutes les lignes dont les cellules de C ne commence pas par M
Set l = .Range("C65536").End(xlUp)
Do While l.Row > 1
If InStr(l, "M") <> 1 Then
    l.EntireRow.Delete
    Set l = .Range("C65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop

'insertion d'une colonne pour constituer ma valeur
.Columns("D").Insert
.Columns("H").Insert
.Columns("I").Insert
.Columns("J").Insert
.Columns("K").Insert
.Columns("L").Insert
.Columns("M").Insert
.Columns("N").Insert
.Columns("M").Insert
.Columns("N").Insert
.Columns("O").Insert
.Cells(1, 2) = "Fournisseur"
.Cells(1, 4) = "PO-LG"
.Cells(1, 8) = "Qtés RCT-PO"
.Cells(1, 9) = "Qté ASN"
.Cells(1, 10) = "Date RCT-PO"
.Cells(1, 11) = "Qté RCT-C3D"
.Cells(1, 12) = "Date RCT-C3D"
.Cells(1, 13) = "Qté En Transit"
.Cells(1, 14) = "Date Prévue-C3D"
.Cells(1, 15) = "Product Line"
.Cells(1, 16) = "CDC FY"
.Cells(1, 17) = "CDC Period"

'concatène C et "-" et S
    Set c = .Range("D2")
    Do While c.Offset(0, -1) <> ""
        c = c(1, 0) & "-" & Format(c(1, 19), "000")
        Set c = c.Offset(1, 0)
    Loop
End With
'prise en compte de la page "5-17"
'With Sheets("5-17")

'remplace ? par Transit.
With Sheets("5-17").Range("AB:AB")
    Set j = .Find(What:="?", LookIn:=xlValues, lookat:=xlWhole)
    If Not j Is Nothing Then
        Do
            j.Value = "Transit"
            Set j = .FindNext(j)
        Loop While Not j Is Nothing
    End If
'prise en compte de la page "5-17"
With Sheets("5-17")
'insertion d'une colonne
.Columns(6).Insert
.Cells(1, 6) = "PO-LG"

'transforme les cellules texte en nombre. Tester vide
For i = 2 To .Range("K65536").End(xlUp).Row
    .Cells(i, 11) = CDbl(Trim(Replace(Cells(i, 11), ".", ",")))
Next
'supprime toutes les lignes dont les cellules de E ne commence pas par M
Set l = .Range("E65536").End(xlUp)
Do While l.Row > 1
Application.StatusBar = l.Row
If InStr(l, "M") <> 1 Then
    l.EntireRow.Delete
    Set l = .Range("E65536").End(xlUp)
Else: Set l = l(0, 1)
End If
Loop

'concatène E et "-" et Hf
Set d = .Range("F2")
    Do While d.Offset(0, -1) <> ""
    d = d(1, 0) & "-" & Format(d(1, 3), "000")
    Set d = d.Offset(1, 0)
    Loop
End With


Set c = Worksheets("5-9-12").Range("D" & Worksheets("5-9-12").Range("D65536").End(xlUp).Row)
Do While c.Row > 1
Somme& = 0
With Worksheets("5-17").Range("F2:F" & Worksheets("5-17").Range("F65536").End(xlUp).Row)
    Set d = .Find(c)
        If Not d Is Nothing Then
            Départ = d.Address
            Do
                Somme& = d(1, 6) + Somme&
                c(2, 1).EntireRow.Insert
                c(2, 0) = "N° ASN"
                'n° d'ASN OK
                c(2, 1) = d(1, 26)
                'qt dans l'ASN OK
                c(2, 6) = d(1, 6)
                'date rct-po
                c(2, 7) = d(1, 5)
                'date rct-c3d
                c(2, 9) = d(1, 19)
                If d(1, 24) = "Transit" Then
                    c(2, 8) = 0
                    Else: c(2, 8) = d(1, 6)
                End If
                'Qté réceptionnée C3D
                If d(1, 20) = "?" Then
                    c(2, 8) = 0
                ElseIf d(1, 6) = d(1, 18) Then
                    c(2, 8) = d(1, 6)
                ElseIf d(1, 6) - d(1, 18) <> 0 Then
                c(2, 8) = d(1, 6) - d(1, 18)
                Else
                End If
                'date prévue c3d
                c(2, 11) = d(1, 24)
                If d(1, 24) = "Transit" Then
                    c(2, 11) = d(1, 23)
                    Else: c(2, 10) = d(1, 18)
                End If
                'Qté en transit
                If c(2, 6) = c(2, 8) Then
                    c(2, 10) = 0
                    Else: c(2, 10) = d(1, 18)
                End If
                Set d = .FindNext(d)
        Loop While Not d Is Nothing And d.Address <> Départ
        End If
    End With
    With Worksheets("TradeCard").Range("E2:E" & Worksheets("TradeCard").Range("E65536").End(xlUp).Row)
    Set f = .Find(c)
        If Not f Is Nothing Then
            Départ = f.Address
            Do
                c(1, 12) = f(1, 14)
                c(1, 13) = f(1, 46)
                c(1, 14) = f(1, 47)
        Loop While Not f Is Nothing And f.Address <> Départ
        End If
    End With

'on fait le total de tous les ASN
c(1, 5) = Somme&
Set c = c(0, 1)
Loop
With Worksheets("5-9-12")
.Range("J:J,L:L,N:N").NumberFormat = "dd/mm/yyyy"
.Columns("A:X").Columns.AutoFit
.Columns("A:X").HorizontalAlignment = xlCenter
End With
End With
Application.ScreenUpdating = True
End Sub