Optimisation Code - Macro trop lente

Le 20/11/2015 à 05:46

Bonjour,

Ma macro est assez aléatoire au niveau du temps d’exécution. Des fois celle-ci peux prendre 5 minutes comme 10 secondes sur mon PC.

Je veux utiliser cette macro sur excel 2007 et 2010 et dans ces cas là c'est vraiment vraiment long.

Ma macro permet de créer plusieurs contrats PDF à la suite.

En faisant des recherches sur les forums j'ai pu optimiser déjà un petit peu en désactivant le rafraîchissement de l'écran.

Voici mon code, voyez vous des optimisations possibles, simplification pour que le fichier soit plus performant et léger ?

Option Explicit
Sub CreaContrat()

    Dim Dossier As String
    Dim NomFichier As String
    Dim NomDossier As String
    Dim SousDossier As String
    Dim NomCompletFichier As String
    Dim NomPersonne As String
    Dim stHeureExport As String
    Dim stDateExport As String
    Dim i, j, nb As Integer
'Optimisation fichier'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'Remplissage des colonnes'
j = Sheets("generator").UsedRange.Rows.Count - 3

'Chemin courant'
Dossier = Application.ActiveWorkbook.Path & "\Contrat Kiva\"

'Ligne définitive :
'NomCompletFichier = ChDir & "\" & NomFichier
nb = 0

For i = 0 To j - 1

    If Worksheets("generator").Range("Cree").Offset(i).Value = "" And Not IsEmpty(Worksheets("generator").Range("name").Offset(i).Value) Then

    With Worksheets("generator")

        Worksheets("Contract").Range("B12").Value = .Range("name").Offset(i).Value
        Worksheets("Contract").Range("F64").Value = .Range("name").Offset(i).Value
        Worksheets("Contract").Range("D9").Value = .Range("khmer").Offset(i).Value
        Worksheets("Contract").Range("C18").Value = .Range("loom").Offset(i).Value
        Worksheets("Contract").Range("E18").Value = .Range("dollar").Offset(i).Value
        Worksheets("Contract").Range("G18").Value = .Range("thb").Offset(i).Value
        Worksheets("Contract").Range("I20").Value = .Range("thbscarf").Offset(i).Value
        Worksheets("Contract").Range("D25").Value = .Range("ddate").Offset(i).Value
        Worksheets("Contract").Range("D26").Value = .Range("ddate").Offset(i).Value
        Worksheets("Contract").Range("D29").Value = .Range("rdate").Offset(i).Value
        Worksheets("Contract").Range("D30").Value = .Range("rdate").Offset(i).Value
        Worksheets("Contract").Range("D39").Value = .Range("sdate").Offset(i).Value

        .Range("Cree").Offset(i).Value = "Created on " & VBA.Format(VBA.Date, "dd/mm/yy") & VBA.Chr(10) & " at " & VBA.Format(VBA.Time, "hh:mm")

        NomFichier = .Range("name").Offset(i).Value & " " & .Range("season").Offset(i).Value & " " & .Range("ref").Offset(i).Value & " M" & .Range("num").Offset(i).Value & " "
        SousDossier = Range("name").Offset(i).Value & stHeureExport

    End With

    'Pour les tests, on ajoute l'heure au nom de fichier ; ainsi, il n'y a pas de doublon de noms
    stHeureExport = VBA.Format(VBA.Time, "hhmmss")
    stDateExport = VBA.Format(VBA.Date, "dd-mm-yy")

    NomCompletFichier = Dossier & NomFichier & stDateExport & "  " & stHeureExport

    'Création Dossier si il n'est pas présent'
    If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier

    'Copie de la feuille courante dans un nouveau classeur et enregistrement'
    'XLS'
    'Worksheets("Notification").Copy'
    'ActiveWorkbook.SaveAs Filename:=NomCompletFichier'

    'PDF'
    Worksheets("Contract").ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomCompletFichier & ".pdf", Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    From:=1, To:=2, OpenAfterPublish:=False

    'ActiveWorkbook.Close'

    nb = nb + 1

    End If

   Next i

    'Boite texte'
  MsgBox "Contract created and saved" & vbCrLf & vbCrLf & CStr(nb) & " in " & vbCrLf & Dossier

 'Optimisation fichier'
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Merci d'avance,

Pierre

Le 21/11/2015 à 07:08

Bonjour,

je mettrais le test du dossier :

'Création Dossier si il n'est pas présent'

If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier

en dehors de la boucle, juste après l'assignation de la variable dossier.

C'est toujours un test en moins à faire...

Pour le nom du fichier :

'Pour les tests, on ajoute l'heure au nom de fichier ; ainsi, il n'y a pas de doublon de noms

stHeureExport = VBA.Format(VBA.Time, "hhmmss")

stDateExport = VBA.Format(VBA.Date, "dd-mm-yy")

NomCompletFichier = Dossier & NomFichier & stDateExport & " " & stHeureExport

je remplacerais par :

NomCompletFichier= Dossier & NomFichier & Format(Now, "YYYY-MM-DD à HH-MM-SS")

sans pré calcul.

Au niveau de la date je met année mois jour afin de pouvoir trier les fichiers du plus récent vers le plus vieux et inversement, chose qu'avec le format français on ne peut pas faire...

@ bientôt

LouReeD

Le 23/11/2015 à 03:28

Merci je teste, d'autres idées ?

Le 23/11/2015 à 19:09

Bonsoir,

merci de tester... tenez moi au courant...

@ bientôt

LouReeD

Le 15/12/2015 à 05:05

Merci , j'ai fait les modifs j'ai un code un peu plus clair !

Mais aucune différence niveau performance, je pense que le PC est trop vieux.

Le 15/12/2015 à 22:24

Bonjour,

et ben tant pis alors...

Ceci dit avec un fichier test on pourrait essayer de voir comment il tourne sur d'autre machine, mais votre fichier est certainement confidentiel, alors peut-être pouvez vous le rendre anonyme en supprimant les noms, n° de tél etc...

Ceci permettrait de tester en vrai plutôt que de faire des hypothèses, en faite c'est peut-être la "structure" même de votre routine qu'il faut changer, mais je dois avouer ne pas réussir à me "projeter" dans le fonctionnement tel que je la vois actuellement...

@ bientôt

LouReeD

Le 16/12/2015 à 02:01

Je t'ai transmis la pièce jointe en MP.

Merci !

Le 16/12/2015 à 06:09

Bonjour,

dès que j'ai un moment je regarde ça !

@ bientôt

LouReeD

Rechercher des sujets similaires à "optimisation code macro trop lente"