Ralentir une Macro

Bonjour,

Essais effectués, cela fonctionne dans les 2 cas, je vais conserver la prog de la macro avec la fonction "DoEvents" qui est plus rapide.

Merci à vous pour votre aide sur ce sujet.

Cordialement

Bonjour,

Pour ralentir votre macro et ajouter un délai de 3 à 5 secondes entre chaque génération et envoi d'avis de passage, vous pouvez insérer une pause dans la boucle principale à l'aide de la fonction Application.Wait. Voici comment modifier votre code pour ajouter un délai de 5 secondes (vous pouvez ajuster à 3 secondes si nécessaire) après chaque envoi d'email.

J'ai modifié votre code :

Sub Creer_ADP()

Dim ligne As Integer
Dim Nombre As Integer
Dim colonne As Integer

Dim nom_pdf As String
Dim chemin_pdf As String
Dim cheminsave As String
Dim chemin_sect As String
Dim chemin_sect2 As String

Dim destinataire, sujet, fichierjoint As String
Dim Chem As String, Rep As String, Fich As String, Dest As String

'Actualisation données emails
'============================
Sheets("Répartition").Select
ThisWorkbook.RefreshAll
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotFields("Fax / Email").CurrentPage = "Email"

'Afficher le nombre d'envois
'===========================
Sheets("Avis de passage VP").Select
MsgBox "Nombre Total d'avis à envoyer = " & ActiveSheet.Range("U3").Value

'Boucle
'=======
Sheets("Avis de passage VP").Select

Nombre = ActiveSheet.Range("U4").Value
ligne = 7
colonne = 22

Worksheets("Répartition").Range("A" & ligne).Copy Worksheets("Avis de passage VP").Range("F1")

Do While ligne < Nombre

    Worksheets("Répartition").Range("A" & ligne).Copy Worksheets("Avis de passage VP").Range("F1")
    ligne = ligne + 1
    colonne = colonne + 1

    'Impression PDF
    '==============
    Sheets("Avis de passage VP").Select
    nom_pdf = ActiveSheet.Range("J5").Value & ".pdf"
    chemin_pdf = ActiveSheet.Range("J18").Value & nom_pdf
    chemin_sect2 = ActiveSheet.Range("J19").Value

    'création PDF avec ADOBE
    '=======================
    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=chemin_pdf, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
            
    'Copier ok dans A COLLER MAUDE colonne créé :
    '===========================================
    Sheets("Avis de passage VP").Select
    Worksheets("A coller MAUDE").Range("BG" & Range("J1")) = Worksheets("Avis de passage VP").Range("H1")
            
    'Envoi Email avec OUTLOOK :
    '=========================
    Dim OutApp As Object 'Déclaration de l'application objet Outlook
    Dim OutMail As Object 'Déclaration du mail objet Outlook
    Dim attach As String
    Dim signature As String
    Dim sigstring As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.createitem(0)

    attach = Worksheets("Avis de passage VP").Range("J20")

    With OutMail 'début de la boucle
        .To = Worksheets("Avis de passage VP").Range("J27")
        .CC = Worksheets("Avis de passage VP").Range("L1")
        .Subject = Worksheets("Avis de passage VP").Range("J6")
        .display
        .htmlbody = "Bonjour," & "<Br>" & "<Br>" & Worksheets("Avis de passage VP").Range("J7") & "<Br>" & "<Br>" & "Restant à votre disposition." & "<Br>" & .htmlbody
        .Attachments.Add attach
        .display 'affiche le mail en brouillon dans Outlook
        '.Send 'envoie directement le mail
        '.Save 'sauvegarde le mail

        'Copier ok dans A COLLER MAUDE colonne envoyé :
        '===========================================
        Sheets("Avis de passage VP").Select
        Worksheets("A coller MAUDE").Range("BH" & Range("J1")) = Worksheets("Avis de passage VP").Range("H1")
    End With 'fin de la boucle

    ' Ajout du délai de 5 secondes
    Application.Wait Now + TimeValue("00:00:05")

'Fin Boucle :
'============
Loop

'Compter le nombre de fichiers générés :
'=======================================
nbfic = 0
Fichier = Dir(ActiveSheet.Range("J18").Value)
Do While Fichier <> ""
    nbfic = nbfic + 1
    Fichier = Dir
Loop

MsgBox ("Nombre de fichiers générés = ") & ActiveSheet.Range("U3").Value

'ouvrir le dossier d'enregistrement du fichier
'=============================================
Shell "explorer.exe /e," & chemin_sect2, vbNormalFocus

End Sub

Conseils supplémentaires :

Testez avec un petit nombre d'envois : Avant de lancer la macro sur les 200 avis, testez-la sur un échantillon plus petit (par exemple, 10 avis) pour vérifier que le délai résout le problème.
Activez l'envoi automatique : Si vous souhaitez réactiver l'envoi automatique (.Send au lieu de .display), décommentez la ligne .Send et commentez .display après avoir validé que le délai fonctionne.
Optimisation : Pour éviter d'autres erreurs potentielles, assurez-vous que Outlook est bien ouvert avant de lancer la macro, car la création répétée d'objets Outlook (CreateObject("Outlook.Application")) dans la boucle peut également causer des problèmes. Vous pourriez envisager de créer l'objet OutApp une seule fois en dehors de la boucle.

Exemple pour déplacer la création d'Outlook hors de la boucle :

Set OutApp = CreateObject("Outlook.Application") 'Déplacer ici, avant la boucle
Do While ligne < Nombre
    Set OutMail = OutApp.createitem(0) 'Créer un nouvel email à chaque itération
    ' ... (reste du code) ...
Loop
Set OutApp = Nothing 'Libérer l'objet après la boucle

Testez ces modifications et faites-moi savoir si vous rencontrez encore des problèmes.

Bonjour,

Une autre piste, attendre que l'application ait fini un envoi, avant de passer à l'autre.

Après la commande ".Send" (ou ".Save"), rajouter une ligne "DoEvents"

Peut-être?

Bonjour,

Comme préconisé par cousinhub29 je pense qu'un doevents suffit pour redonner la main à Windows pour lui permettre de gérer sa pagination mémoire.