Optimisation Macro

Bonjour

Je sollicite votre aide pour optimiser macro qui me prend beaucoup de temps.

Ci-dessous ma macro Merci infiniment

Sub Valorisation()
timerdebut = Timer
'Dim ligne As Integer
'Dim AB As Variant

'Copie l'annulation

Sheets("SOURCE").Range("A:AE").Copy Sheets("TEST").Range("A:AE")

'insertion des lignes en fonction de l'occurence
'Application.ScreenUpdating = False
DL = Sheets("TEST").Range("AI20000").End(xlUp).Row ' Dernière ligne
For L = DL To 2 Step -1 ' Pour toutes les lignes
If Cells(L, "AI") > 1 Then ' Si nombre de lignes désirées >1
NbDupliq = Cells(L, "AI") ' Mémoriser nombre de lignes à dupliquer
Cells(L, "AI") = 1 ' Mettre Nb lignes à 1
For N = 1 To NbDupliq - 1 ' Pour dupliquer N-1 fois
Cells(L, 1).Select ' Selection ligne
Selection.EntireRow.Copy ' Copie de la ligne
Selection.Insert Shift:=xlDown ' Insertion ligne en dessous
Application.CutCopyMode = False ' Copie des infos
Next N
End If
Next L
'copier dans fichier final

Sheets("TEST").Columns("B:AD").Copy
Sheets("Final").Columns("B:AD").PasteSpecial Paste:=xlPasteValues
Sheets("TEST").Columns("AL:AM").Copy
Sheets("Final").Columns("C:D").PasteSpecial Paste:=xlPasteValues
Sheets("TEST").Columns("AN").Copy
Sheets("Final").Columns("Y").PasteSpecial Paste:=xlPasteValues
Sheets("TEST").Columns("AT").Copy
Sheets("Final").Columns("P").PasteSpecial Paste:=xlPasteValues
'Sheets("Final").Columns("A").Copy
'Sheets("Final").Columns("A").PasteSpecial Paste:=xlPasteValues

'supprimer les lignes en dessous
' ligne = Sheets("TEST").Range("AQ1").Value
'AB = ligne & ":" & "10000"
' MsgBox (AB)
'Sheets("Final").Rows(AB).Select
' Sheets("Final").Rows(AB).Delete

'Application.ScreenUpdating = True
cheminDossier = Sheets("Parametrage").Range("B5")
sortie = "Final" & ".csv"

Sheets("Final").Copy

ActiveWorkbook.SaveAs Filename:=cheminDossier & sortie
'ActiveWorkbook.Close
'Application.DisplayAlerts = False
'Application.Quit

MsgBox "Durée : " & (Timer - timerdebut) & " sec."

End Sub

Bonjour,

Merci de penser à :
- utiliser les balises de code disponible en cliquant sur l'icone </> et en collant votre code dans la fenêtre. (J'ai corrigé à votre place)
- corriger votre profil en mentionnant votre version excel (Français ne veut rien dire et n'aide pas celui qui vous répond)

Sans données confidentielles

Crdlt

Edit : Essayez ceci puis dites moi ce que cela donne chez vous

Sub Valorisation()
Dim DL As Long, L As Long, N As Long
Dim Nbdupliq As Integer
Dim chemindossier As String
Dim sortie As String

'Copie l'annulation

Sheets("SOURCE").Range("A:AE").Copy Sheets("TEST").Range("A:AE")

With Sheets("TEST")
    DL = .Range("AI" & Rows.Count).End(xlUp).Row ' Dernière ligne

    For L = DL To 2 Step -1 ' Pour toutes les lignes
        If .Cells(L, "AI") > 1 Then ' Si nombre de lignes désirées >1
            Nbdupliq = .Cells(L, "AI") ' Mémoriser nombre de lignes à dupliquer
            .Cells(L, "AI") = 1 ' Mettre Nb lignes à 1

            If Nbdupliq > 1 Then
                .Rows(L + 1).Resize(Nbdupliq - 1).Insert
                .Rows(L).Resize(Nbdupliq).FillDown
            End If

        End If
    Next L

    'copier dans fichier final
    .Columns("B:AD").Copy
    Sheets("Final").Columns("B:AD").PasteSpecial Paste:=xlPasteValues
    .Columns("AL:AM").Copy
    Sheets("Final").Columns("C:D").PasteSpecial Paste:=xlPasteValues
    .Columns("AN").Copy
    Sheets("Final").Columns("Y").PasteSpecial Paste:=xlPasteValues
    .Columns("AT").Copy
    Sheets("Final").Columns("P").PasteSpecial Paste:=xlPasteValues
End With

chemindossier = Sheets("Parametrage").Range("B5")
sortie = "Final" & ".csv"
Sheets("Final").Copy
ActiveWorkbook.SaveAs Filename:=chemindossier & sortie
End Sub