amelioration de macro

Sub sup()
    '
    dl = Range("A65000").End(xlUp).Row
    Dim Ws As Worksheet
    Dim oldCalculation As XlCalculation
    oldCalculation = Application.Calculation 'retenir le mode de calcul en cours
    
    'Figer les éléments d'application chronophages
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            .Name = "Lager"
            With .Sort
                .SortFields .Clear
                .SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange Range("A1:A" & dl)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
    Next Ws
    
    With ActiveSheet
        lig = .Cells.Find(What:="*VERTEILER*", LookIn:=xlValues).Row
        .Rows("2:" & lig).EntireRow.Delete
    
    .Range("A1") = "ARTIKEL MENGE W-LG LGM-NR/ART PLATZ DATUM LS/SER/STK-B WAQS..PLI. G V"
    .Range("A1:A" & dl).TextToColumns Destination:=Range("A1"), _
                                     DataType:=xlFixedWidth, _
                                     FieldInfo:=Array(Array(0, 1), Array(14, 1), Array(23, 1), Array(28, 1), Array(39, 2), _
                                                      Array(45, 4), Array(52, 1), Array(65, 1), Array(70, 1)), TrailingMinusNumbers:=True
    .Columns("I:I").Delete Shift:=xlToLeft
    With .Range("A1:A" & dl)
        .Replace " ", "", xlValues, xlByRows, False
        .Replace "/", "", xlValues, xlByRows, False
    Next
    .Range("I2:I" & dl).Formula = "=+DATE(YEAR(F2),MONTH(F2)+6,DAY(F2))<TODAY()"
    End With
    
    'Remettre les paramètres application à leur état initial
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    ActiveSheet.Calculate
    
    ActiveWorkbook.SaveAs Filename:="C:\Temp\Start_lager.xls"
End Sub

 For Each Ws In ActiveWorkbook.Worksheets
        With Ws
            .Name = "Lager"

Sub sup_2()
Dim dl As Long, lig As Long, cel As Range
Application.ScreenUpdating = False
With ActiveSheet
    .Name = "Lager"
    dl = .Cells(.Rows.Count, 1).End(3).Row
    With .Sort
        With .SortFields
            .Clear
            .Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending
        End With
        .SetRange Range("A1:A" & dl)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    lig = .Cells.Find(What:="*VERTEILER*", LookIn:=xlValues).Row
    .Rows("2:" & lig).EntireRow.Delete
    lig = .Cells(.Rows.Count, 1).End(3).Row
    .Range("A1") = "ARTIKEL MENGE W-LG LGM-NR/ART PLATZ DATUM LS/SER/STK-B WAQS..PLI. G V"
    .Range("A1:A" & lig).TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(14, 1), Array(23, 1), Array(28, 1), Array(39, 2), _
    Array(45, 4), Array(52, 1), Array(65, 1), Array(70, 1)), TrailingMinusNumbers:=True
    .Columns("I:I").Delete Shift:=xlToLeft
    For Each cel In Range("A1:A" & lig)
        cel.Value = Replace(Replace(cel.Value, "/", ""), " ", "")
    Next cel
    Range("I2:I" & lig).Formula = "=+DATE(YEAR(F2),MONTH(F2)+6,DAY(F2))<TODAY()"
    .Columns.AutoFit
End With
ActiveWorkbook.SaveAs Filename:="C:\Temp\Start_lager.xls"
End Sub