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

N
  • Question
XL 2016 Code VBA pour envoi de mail avec pdf en piece jointe
Réponses
4
Affichages
307
Phil69970
Phil69970
G
  • Question
Microsoft 365 Vba Excel l'instruction Set OutApp = CreateObject("Outlook.Application") bloque excel
Réponses
2
Affichages
247
laurent950
laurent950
N
  • Question
Microsoft 365 Code VBA
Réponses
7
Affichages
591
TooFatBoy
TooFatBoy
S
  • Résolu(e)
Microsoft 365 Envoi de la signature de l'utilisateur macro envoi de mail
Réponses
3
Affichages
205
spike29
S
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
594
laurent950
laurent950
M
  • Question
Microsoft 365 Question code VBA
Réponses
2
Affichages
348
Maxou69
M
N
  • Question
Microsoft 365 Envoi via Excel avec OutlookNew
Réponses
4
Affichages
393
Titou37P
Titou37P
N
  • Question
Microsoft 365 choisir sa signature outlook depuis vba excel
Réponses
3
Affichages
2 K
NitroX38X
N
N
  • Résolu(e)
XL 2021 Exporter un graphique dans Outlook
Réponses
3
Affichages
438
NLSCt
N
K
  • Résolu(e)
XL 2019 Probleme codage
Réponses
2
Affichages
375
Kevin42560
K

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 53 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
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki