Microsoft 365 Gagner du temps exécution macro & VBA !

max3134 · 19 Juin 2019

Salut à toutes et à tous,

Je pense que cette question a déjà été posé ... mais je n'y arrive pas !
J'ai écris ce code VBA ( code qui me permet d'envoyer des mails selon des confirmations) en suivant :

"" Sub m()

Application.ScreenUpdating = False
Dim MonSujet1 As String
Dim MonDestinataire1 As String
Dim MonContenu1 As String
Dim i As Integer
Dim oMail As MailItem
Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
Shell "Outlook.exe", vbHide
End If

For i = 4 To 15
MonSujet1 = Sheets("EIE").Cells(i, 6)
MonDestinataire1 = Sheets("EIE").Cells(11, 9)
MonContenu1 = "Rappel 1 Importance : " & Sheets("EIE").Cells(i, 2) & Chr(10) & "A réaliser : " & Sheets("EIE").Cells(i, 1)
MonContenu2 = "Rappel 2 Importance : " & Sheets("EIE").Cells(i, 2) & Chr(10) & "A réaliser : " & Sheets("EIE").Cells(i, 1)
MonContenu3 = "Rappel 3 Importance : " & Sheets("EIE").Cells(i, 2) & Chr(10) & "A réaliser : " & Sheets("EIE").Cells(i, 1)

If Sheets("Feuil1").Cells(i, 29).Value = 1 Then
Sheets("Feuil1").Cells(i, 30).Value = 0
Sheets("Feuil1").Cells(i, 31).Value = 0
Sheets("Feuil1").Cells(i, 32).Value = 0
End If

If Sheets("Feuil1").Cells(i, 22) = 1 Then
Call EnvoyerEmail(MonSujet1, MonDestinataire1, MonContenu1)
ElseIf Sheets("Feuil1").Cells(i, 23) = 1 Then
Call EnvoyerEmail(MonSujet1, MonDestinataire1, MonContenu2)
ElseIf Sheets("Feuil1").Cells(i, 24) = 1 Then
Call EnvoyerEmail(MonSujet1, MonDestinataire1, MonContenu3)
End If

Application.Wait Time + TimeSerial(0, 0, 1)

If Sheets("Feuil1").Cells(i, 22).Value = 1 Then
Sheets("Feuil1").Cells(i, 30).Value = 1
End If
If Sheets("Feuil1").Cells(i, 23).Value = 1 Then
Sheets("Feuil1").Cells(i, 31).Value = 1
End If
If Sheets("Feuil1").Cells(i, 24).Value = 1 Then
Sheets("Feuil1").Cells(i, 32).Value = 1
End If

Next i

Worksheets("EIE").Range("C4:C15").Copy Worksheets("Feuil1").Range("AA4")
Worksheets("EIE").Range("A4:A15").Copy Worksheets("Feuil1").Range("Z4")
MsgBox "Test terminé..."

Application.ScreenUpdating = True

End Sub ""

Il fonctionne mais reste lent, environ 40 secondes voir plus d'1 minute.
Ne connaissant pas la programmation je me doute qu'il doit y avoir de solutions pour écrire le code différemment et mieux ...
Quelqu'un peut t'il m'apporter une aide svp Merci d'avance

Staple1600 · 19 Juin 2019

Bonsoir le fil, max3134

max3134
Il nous manque cette procédure : EnvoyerEmail dans le code VBA que tu as posté

max3134 · 24 Juin 2019

Merci !
Voici la procédure : ( un copier/coller)

Sub EnvoyerEmail(ByVal Sujet As String, ByVal Destinataire As String, ByVal ContenuEmail As String, Optional ByVal PieceJointe As String)

On Error GoTo EnvoyerEmailErreur

'définition des variables
Dim oOutlook As Outlook.Application
Dim WasOutlookOpen As Boolean
Dim oMailItem As Outlook.MailItem
Dim Body As Variant

Body = ContenuEmail

'vérification si le Contenu du mail n'est pas vide. Si oui, email n'est pas envoyé. Si vous voulez pouvoir envoyer les email vides, mettez en commentaire les 4 lignes de code qui suivent.
If (Body = False) Then
MsgBox "Mail non envoyé car vide", vbOKOnly, "Message"
Exit Sub
End If

'préparer Outlook
PreparerOutlook oOutlook
Set oMailItem = oOutlook.CreateItem(0)

'création de l'email
With oMailItem
.To = Destinataire
.Subject = Sujet

'CHOIX DU FORMAT
'----------------------
'email formaté comme texte
.BodyFormat = olFormatRichText
.Body = Body

'OU

'email formaté comme HTML
'.BodyFormat = olFormatHTML
'.HTMLBody = "<html><p>" & Body & "</p></html>"
'----------------------

If PieceJointe <> "" Then .Attachments.Add PieceJointe

.Display '<- affiche l'email (si vous ne voulez pas l'afficher, mettez cette ligne en commentaire)
.Save '<- sauvegarde l'email avant l'envoi (pour ne pas le sauvegarder, mettez cette ligne en commentaire)
.Send '<- envoie l'email (si vous voulez seulement préparer l'email et l'envoyer manuellement, mettez cette ligne en commentaire)
End With

'nettoyage...
If (Not (oMailItem Is Nothing)) Then Set oMailItem = Nothing
If (Not (oOutlook Is Nothing)) Then Set oOutlook = Nothing

Exit Sub

EnvoyerEmailErreur:
If (Not (oMailItem Is Nothing)) Then Set oMailItem = Nothing
If (Not (oOutlook Is Nothing)) Then Set oOutlook = Nothing

MsgBox "Le mail n'a pas pu être envoyé...", vbCritical, "Erreur"
With EnvMail
OriginatorDeliveryReportRequested = True 'confirmation de réception
ReadReceiptRequested = True 'confirmation de lecture

End With
End Sub

Private Sub PreparerOutlook(ByRef oOutlook As Object)
'par Excel-Malin.com ( https://excel-malin.com )

'------------------------------------------------------------------------------------------------
'Ce code vérifie si Outlook est prêt à envoyer des emails... Et s'il ne l'est pas, il le prépare.
'------------------------------------------------------------------------------------------------
On Error GoTo PreparerOutlookErreur

On Error Resume Next
'vérification si Outlook est ouvert
Set oOutlook = GetObject(, "Outlook.Application")

If (Err.Number <> 0) Then 'si Outlook n'est pas ouvert, une instance est ouverte
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
Else 'si Outlook est ouvert, l'instance existante est utilisée
Set oOutlook = GetObject("Outlook.Application")
oOutlook.Visible = True
End If
Exit Sub

PreparerOutlookErreur:
MsgBox "Une erreur est survenue lors de l'exécution de PreparerOutlook()..."
End Sub

Merci d'avance

Microsoft 365 Gagner du temps exécution macro & VBA !

max3134

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

max3134

XLDnaute Nouveau

Discussions similaires