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