Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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
Re

erreur de syntaxe apparement... Capricieux VBA...
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...

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
 

Ezen

XLDnaute Nouveau
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


 

Phil69970

XLDnaute Barbatruc
Bonjour @Ezen , Robert

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

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

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

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

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

@Phil69970
 

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:

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

Ezen

XLDnaute Nouveau
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
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
 

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:

Ezen

XLDnaute Nouveau
Wow ça marche presque!! Les 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!
 

Phil69970

XLDnaute Barbatruc
Re

erreur de syntaxe apparement... Capricieux VBA...
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
 

Discussions similaires

Réponses
7
Affichages
592
Réponses
2
Affichages
348
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…