XL 2016 Boucle ne fonctionne pas lors d'un envoi des plusieurs mail

dindin

XLDnaute Occasionnel
Bonjour le Forum,
j'utilise un code VBA pour envoyer plusieurs mail à des clients (120) avec :
- mail nominatif à chaque destinataire
- joindre une facture nominative à chacun et un courrier (le même) à tout le monde.

tout fonctionne très bien sauf la boucle qui va joindre la facture nominative de chacun. Il y a un blocage je ne sais pas ou.
en fait la boucle joint la facture du 1 er client à tout le monde, ce qui n'est pas de tout l'objectif.
pour des raisons de confidentialité, je ne pourrai pas joindre le fichier, mais voici le code en question:

VB:
Sub envoi_mails()

'envoi mail
ActiveWorkbook.Save
'Feuil16.Range("I2").Value = Destinataire.Value
  Dim ListeDest()
  Dim ListeComment()
  Dim i As Long
  Dim oMsgApp As Object
  Dim oMsg As Object
  Dim sListeDest As String
  Dim sFichier As String
   'déclarer les variable
  Dim a As Variant, name As String
  'Dim li As String
  name = ActiveWorkbook.name
  ChDir ThisWorkbook.Path ' & "\" & "Formulaire_Dm"
  'si fichier selectionné ouvrir en arrière plan outlook
  Set oMsgApp = CreateObject("Outlook.Application")

  ListeDest() = Range("Tableau2[Mail]")
  ListeComment() = Range("Tableau2[Commentaire]")
   'sFichier = Range("Tableau2[joint]")
 
   li = Sheets("Base destinataire_formulaire").Cells(3600, 1).End(xlUp).Row ' a partir de la ligne 36000 TROUVE LA 1ER CELLULE VIDE EN REMONTANT DANS LA COLONNE 1 (a)
For i = 2 To li
sFichier = Sheets("Base destinataire_formulaire").Cells(i, 6).Value


Next

  For i = LBound(ListeDest(), 1) To UBound(ListeDest(), 1)
    Set oMsg = oMsgApp.CreateItem(0)
    With oMsg
      .To = ListeDest(i, 1)
      .Attachments.Add sFichier 'fichier en pc jointe
      .Subject = "Votre Formulaire de rénouvellement" ' : " & ActiveSheet.Range("B15").Value & " _ " & ActiveSheet.Range("E9").Value & " _ " & ActiveSheet.Range("I27").Value 'objet du mail
      .Body = "Bonjour" & Chr(10) & Chr(13) & _
        ListeComment(i, 1) & Chr(10) & Chr(13) & "Restant à votre disposition"
      .Send
    End With
    Set oMsg = Nothing
  Next

  oMsgApp.Quit
  Set oMsgApp = Nothing
  MsgBox " Mails envoyés avec succés "


End Sub

le blocage est dans cette boucle
Code:
 li = Sheets("Base destinataire_formulaire").Cells(3600, 1).End(xlUp).Row ' a partir de la ligne 36000 TROUVE LA 1ER CELLULE VIDE EN REMONTANT DANS LA COLONNE 1 (a)
For i = 2 To li
sFichier = Sheets("Base destinataire_formulaire").Cells(i, 6).Value

j'aurai besoin de votre aide SVP pour remédier à ce souci
Merci d'avance
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Dindin,
Sans fichier test, on ne peut que supputer.
Dans la PJ, on voit que votre boucle est correcte.

Je pense que le problème est autre. En particulier, en sortie de boucle vous aurez toujours le fichier de la ligne "li" :
VB:
sFichier = Sheets("Base destinataire_formulaire").Cells(li, 6).Value
puisqu'on boucle et qu'il n'y a rien après sfichier=..., donc ou c'est la bonne valeur et donc la boucle est inutile, ou ce n'est pas la bonne valeur et il vous manque un bout de code. Dans l'état sfichier ne peut avoir que cette valeur.
 

Pièces jointes

  • Classeur1.xlsm
    15 KB · Affichages: 22

dindin

XLDnaute Occasionnel
Bonjour Dindin,
Sans fichier test, on ne peut que supputer.
Dans la PJ, on voit que votre boucle est correcte.

Je pense que le problème est autre. En particulier, en sortie de boucle vous aurez toujours le fichier de la ligne "li" :
VB:
sFichier = Sheets("Base destinataire_formulaire").Cells(li, 6).Value
puisqu'on boucle et qu'il n'y a rien après sfichier=..., donc ou c'est la bonne valeur et donc la boucle est inutile, ou ce n'est pas la bonne valeur et il vous manque un bout de code. Dans l'état sfichier ne peut avoir que cette valeur.
je viens de joindre un fichier test si ça pourra vous aider
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Je ne dispose pas d'outlook pour tester.
En PJ ce qui me semblerait plus pertinent : transfert des fichier dans un tableau et affectation de ces fichiers en fonction du destinataire.
VB:
' Transfert tableau
  ListeDest() = Range("Tableau2[Mail]")
  ListeComment() = Range("Tableau2[Commentaire]")
  ListeFichier() = Range("Tableau2[joint]")

' Affectation fichier
  sFichier = ListeFichier(i, 1)
 

Pièces jointes

  • Essai 2022 (1).xlsm
    36.3 KB · Affichages: 20

dindin

XLDnaute Occasionnel
Je ne dispose pas d'outlook pour tester.
En PJ ce qui me semblerait plus pertinent : transfert des fichier dans un tableau et affectation de ces fichiers en fonction du destinataire.
VB:
' Transfert tableau
  ListeDest() = Range("Tableau2[Mail]")
  ListeComment() = Range("Tableau2[Commentaire]")
  ListeFichier() = Range("Tableau2[joint]")

' Affectation fichier
  sFichier = ListeFichier(i, 1)
c'est vraiment top
c'est cette phrase qu'il manquait à mon code
VB:
 sFichier = ListeFichier(i, 1)
et qu'il fallait l'inserer dans la 2 ème boucle d'envoi
Merci beaucoup
joli travail
je viens de faire le test sur mon fichier original
Top
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Jeremy,
Le fichier de Dindin envoie déjà des mails par liste puisqu'il parcourt "Tableau2[Mail]" dans sa totalité.
Pour la PJ en pdf, vous avez plusiurs exemples comme :