[XL-2013] Optimisation Code et Macro

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 ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
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