Macro... rapidité à améliorer

Sub mef_RPORDO()
    Dim c As Range, adr1 As String, lig As String, CalcStatus As Long
    lig = 5
    Application.ScreenUpdating = False
    CalcStatus = Application.Calculation
    Application.Calculation = xlCalculationManual

    With [C4].Resize(Cells(Rows.Count, "C").End(xlUp).Row - 3)
        Set c = .Find("Livraisons", LookIn:=xlValues, lookat:=xlWhole)
        If Not c Is Nothing Then
            Do
                ' si trouvé
                c.Offset(0, -1) = c.Offset(2, -1)
                Range(lig & ":" & c.Row - 1).Delete
                lig = c.Row + 1
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> "$C$5"
        End If
    End With
    Range(lig & ":" & lig + 20).Delete
    Application.ScreenUpdating = True
    Application.Calculation = CalcStatus
End Sub

Public Sub selection_livraisons()
Dim Lig As Long, mnt As Variant, vlB As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    For Lig = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
        vlB = Cells(Lig, "B").Value
        If IsNumeric(vlB) And vlB > 0 Then mnt = vlB
        If Not (Cells(Lig, 3) Like ("Livraisons")) Then
            Rows(Lig).Delete
        Else
            Cells(Lig, "B").Value = mnt: mnt = ""
        End If
    Next Lig
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub