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

M

max3134

XLDnaute Nouveau
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
 
Trier par date Trier par votes
M

max3134

XLDnaute Nouveau
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 :)
 
Vote positif 0 Vote négatif

Discussions similaires

lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
487
AtTheOne
AtTheOne
S
  • Question
XL 2019 Modifications avec Combobox liées
Réponses
7
Affichages
138
Dranreb
Dranreb
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
506
laurent950
laurent950
D
  • Question
XL 2010 Recherche cellule vide sur une ligne
Réponses
9
Affichages
256
job75
job75
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
303
pangasoul
P
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
927
Nicolas JACQUIN
Nicolas JACQUIN
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
316
Gégé-45550
Gégé-45550
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
324
CathyLD
C
Jojo973
  • Question
Microsoft 365 Trier des données et les afficher sur une autre feuille
Réponses
10
Affichages
342
Jojo973
Jojo973
P
  • Résolu(e)
Microsoft 365 Macro qui change l'épaisseur du contour d'une forme
Réponses
11
Affichages
255
pat66
P

Membres actuellement en ligne

21 membres et 270 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 709
Messages
2 112 107
Membres
111 423
dernier inscrit
buritis