Autres "Incrémenter" les cellules dans une macro grace à une boucle ?

E

Ezen

XLDnaute Nouveau
Bonjour à tous, je suis tout à fait néophyte de VBA et j'ai quelques questions sur ce qui est faisable ou non.

J'ai une macro qui permet d'envoyer directement un mail via outlook a un destinataire dont le mail est dans une cellule précise, pareil pour la personne en CC. De la meme maniere le mail est accompagné d'une PJ dont le chemin d'accès se trouve dans une cellule. Voyez la macro (fonctionnelle en l'état mais peu utile) ci-dessous :


Sub mail_outlook()

Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Set ws = Sheets("Clients - Fichier Clients")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
.To = ws.Range("C2").Value
.CC = ws.Range("D2").Value
.BCC = ""
.Subject = "Test de X"
.Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
.Attachments.Add ws.Range("X2").Value
On Error GoTo 0

.Display

End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Maintenant je voudrais changer cette macro de manière à ce qu'elle se repete tout en passant à la ligne du dessous à chaque fois. Concrètement : au lieu d'aller chercher
.To en C2 ; .CC en D2 et .Attachments.Add en X2 je voudrais qu'à la 1ere repetition la macro aille chercher .To en C3 ; .CC en D3 et .Attachments.Add en X3 puis à la repetition suivante .To en C4 ; .CC en D4 et .Attachments.Add en X4 et ainsi de suite jusqu'à trouver une ligne vide...

J'ai bien évidemment copié la plus grosse partie de cette macro sur le net et je ne sais pas comment m'y prendre pour la changer comme décrit plus haut....

Merci par avance à tous les pros d'excel/VBA qui m'aideront! 🥳

A+

Ezen
 
Solution
Phil69970
Re

Ezen à dit:
erreur de syntaxe apparement... Capricieux VBA...
Cliquez pour agrandir...
Non juste beaucoup d’étourderie de ma part, j’avais oublié le .

VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim I As Integer
Dim DL As Integer

Set ws = Sheets("Feuil1")
DL = ws.Cells(Application.Rows.Count, "A").End(xlUp).Row
For I = 2 To DL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .to = ws.Cells(I, "A").Value
        .cc = ""
        .BCC = ""
        .Subject = "Test de X"
        .Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        'On Error Resume Next
        If ws.Cells(I...
Trier par date Trier par votes
Robert

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Ezen, bonjour le forum,

Peut-être comme ça :
VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim DL As Integer
Dim I As Integer

Set ws = Sheets("Clients - Fichier Clients")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
DL = ws.Cells(Application.Rows.Count, "C").End(xlUp).Row
For I = 2 To DL
    With OutMail
        .to = ws.Cells(I, "C").Value
        .cc = ws.Cells(I, "D").Value
        .BCC = ""
        .Subject = "Test de X"
        .Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        .Attachments.Add ws.Cells(I, "X").Value
        On Error GoTo 0
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
Next I
End Sub
 
Vote positif 0 Vote négatif
E

Ezen

XLDnaute Nouveau
Robert à dit:
Bonjour Ezen, bonjour le forum,

Peut-être comme ça :
VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim DL As Integer
Dim I As Integer

Set ws = Sheets("Clients - Fichier Clients")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
DL = ws.Cells(Application.Rows.Count, "C").End(xlUp).Row
For I = 2 To DL
    With OutMail
        .to = ws.Cells(I, "C").Value
        .cc = ws.Cells(I, "D").Value
        .BCC = ""
        .Subject = "Test de X"
        .Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        .Attachments.Add ws.Cells(I, "X").Value
        On Error GoTo 0
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
Next I
End Sub
Cliquez pour agrandir...
Salut Robert,

Merci pour ton aide, on y est presque je pense. Pour le moment j'ai une erreur à la ligne attachments.add... Le problème vient à priori du fait que pour certaines lignes il n'y a pas de PJ à envoyer donc la macro plante, il me semble en tout cas (code erreur ci-dessous). Quelqu'un a-t-il une idée de comment corriger ça ?

Merci d'avance 😊😊

1639995425004.png

1639995677812.png
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Bonjour @Ezen , Robert

Edit : Robert à eu la même idée que la solution 2 ci dessous

Ezen à dit:
Le problème vient à priori du fait que pour certaines lignes il n'y a pas de PJ à envoyer donc la macro plante,
Cliquez pour agrandir...

Il faut :
1)Soit vérifier si il y a une PJ
If ws.Cells(I, "X").Value <> "" Then .Attachments.Add ws.Cells(I, "X").Value
Cliquez pour agrandir...

2) Soit gérer l'erreur avec avant la ligne qui plante
On Error Resume Next
Cliquez pour agrandir...

Perso je préfère la 1ere solution quand c'est possible

@Phil69970
 
Vote positif 0 Vote négatif
E

Ezen

XLDnaute Nouveau
Merci à tous les deux, effectivement c'est ok pour cette erreur là. Maintenant la macro fonctionne bien avec le CC la PJ etc mais seulement sur la ligne 2 du fichier... La macro ne tourne toujours pas sur toutes les lignes...🤔

EDIT : ci-dessous la macro actuelle suite aux modifs suggérées, j'ai peut-être zappé quelque chose ?

Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim I As Integer
Dim DL As Integer

Set ws = Sheets("Feuil1")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
DL = ws.Cells(Application.Rows.Count, "C").End(xlUp).Row
For I = 2 To DL
With OutMail
.To = ws.Cells(I, "C").Value
.cc = ws.Cells(I, "D").Value
.BCC = ""
.Subject = "Test de X"
.Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
On Error Resume Next
.Attachments.Add ws.Cells(I, "X").Value
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next I
End Sub

La même chose avec la solution 1 de Phil fonctionne aussi d'ailleurs! ;)
 
Dernière édition:
Vote positif 0 Vote négatif
E

Ezen

XLDnaute Nouveau
12, et c'est bien le nombre de cellules non vides dans la colonne A... C'est ce que je trouve bizarre.
Le fichier contient des infos pro mais j'ai fais un fichier "test" pour te le partager, je modifierai la macro après pour l'autre fichier ça sera pas un soucis.

Merci encore pour l'aide!
 

Pièces jointes

  • TESTMACRO.xlsm
    23.1 KB · Affichages: 7
Vote positif 0 Vote négatif
E

Ezen

XLDnaute Nouveau
Phil69970 à dit:
Re

Les set sont déchargés à la fin de la 1erer boucle

il faut modifier


par :

pour que la boucle se fasse comme il faut.

*Merci de ton retour

@Phil69970
Cliquez pour agrandir...
Je viens de tester, maintenant la macro ouvre un brouillon à destination de la derniere adresse mail de la colonne A (les adresses se remplacent jusqu'à s'arreter sur la derniere) et les 12 PJ se mettent sur ce même brouillon. La macro n'ouvre pas un brouillon par ligne :confused:
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Re

Alors if faut peut être faire le contraire pour recréer un mail par boucle

VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim I As Integer
Dim DL As Integer

Set ws = Sheets("Feuil1")
DL = ws.Cells(Application.Rows.Count, "A").End(xlUp).Row
For I = 2 To DL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        to = ws.Cells(I, "A").Value
        cc = ""
        BCC = ""
        Subject = "Test de X"
        Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        'On Error Resume Next
        If ws.Cells(I, "H").Value <> "" Then .Attachments.Add ws.Cells(I, "H").Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
Next I

End Sub

@Phil69970
 
Dernière édition:
Vote positif 0 Vote négatif
E

Ezen

XLDnaute Nouveau
Phil69970 à dit:
Re

Alors if faut peut être faire le contraire pour recréer un mail par boucle

VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim I As Integer
Dim DL As Integer

Set ws = Sheets("Feuil1")
DL = ws.Cells(Application.Rows.Count, "A").End(xlUp).Row
For I = 2 To DL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        too = ws.Cells(I, "A").Value
        MsgBox too
        cc = ""
        BCC = ""
        Subject = "Test de X"
        Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        'On Error Resume Next
        If ws.Cells(I, "H").Value <> "" Then .Attachments.Add ws.Cells(I, "H").Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
Next I

End Sub

@Phil69970
Cliquez pour agrandir...
Wow ça marche presque!! o_OLes brouillons s'ouvrent un à un avec la bonne PJ. Par contre maintenant c'est le destinataire/l'objet du mail/le texte du corps du mail qui sautent et qui n'apparaissent pas...
Mais c'est presque ça!

Merci beaucoup!
 
Vote positif 0 Vote négatif
Phil69970

Phil69970

XLDnaute Barbatruc
Re

Ezen à dit:
erreur de syntaxe apparement... Capricieux VBA...
Cliquez pour agrandir...
Non juste beaucoup d’étourderie de ma part, j’avais oublié le .

VB: 
Sub mail_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim xMailBody As String
Dim ws As Worksheet
Dim I As Integer
Dim DL As Integer

Set ws = Sheets("Feuil1")
DL = ws.Cells(Application.Rows.Count, "A").End(xlUp).Row
For I = 2 To DL
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .to = ws.Cells(I, "A").Value
        .cc = ""
        .BCC = ""
        .Subject = "Test de X"
        .Body = "Ceci est un message test." & vbCrLf & "ceci est une nouvelle ligne"
        'On Error Resume Next
        If ws.Cells(I, "H").Value <> "" Then .Attachments.Add ws.Cells(I, "H").Value
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
Next I

End Sub

@Phil69970
 
Vote positif 1 Vote négatif
Solution

Discussions similaires

M
  • Question
Microsoft 365 Question code VBA
Réponses
2
Affichages
112
Maxou69
M
N
  • Question
Microsoft 365 choisir sa signature outlook depuis vba excel
Réponses
3
Affichages
1 K
NitroX38X
N
N
  • Résolu(e)
XL 2021 Exporter un graphique dans Outlook
Réponses
3
Affichages
172
NLSCt
N
K
  • Résolu(e)
XL 2019 Probleme codage
Réponses
2
Affichages
221
Kevin42560
K
halecs93
  • Question
Microsoft 365 Générer mail via Excel
Réponses
2
Affichages
217
halecs93
halecs93
My<3
  • Question
XL 2019 HTML Corps de mail
Réponses
6
Affichages
295
My<3
My<3
S
  • Question
XL 2021 macro VBA excel
Réponses
1
Affichages
164
crocrocro
C
A
  • Résolu(e)
XL 2021 Macro de création mail de relance avec référence cellules
Réponses
4
Affichages
243
arnoldbrice19
A
Chaton0408
  • Question
Microsoft 365 VBA Création Question liste destinataire
Réponses
6
Affichages
138
youky(BJ)
youky(BJ)
C
  • Résolu(e)
XL 2013 vba - envoi d'un mail avec le choix de l'adresse mail expéditeur (qd on a 2 comptes)
Réponses
4
Affichages
464
Chrystel01
C

Membres actuellement en ligne

19 membres et 199 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
312 160
Messages
2 085 838
Membres
103 000
dernier inscrit
Nath13