Microsoft 365 Aide au publipostage et envoi en nombre de fichiers et/ou mails

[DARRIEUX]

Demande auprès de EXCEL DOWNLOADS​

Bonjour,

Je suis nouveau bénévole à la Banque Alimentaire à Pau. Je souhaiterais optimiser la communication auprès des bénévoles lors des collectes. Aujourd’hui le bénévole qui gère l’organisation envoi près de 400 mails à la main après avoir saisi mail du bénévole et copier/coller d’un tableau Excel. J’ai dans le passé, dans mon entreprise, utilisé du publipostage Word Excel et envoi auprès de 1500 salariés environ, mais je n’ai plus les fichiers utilisés. Aussi je vous serais très reconnaissant de m’aider à l’optimisation de ces envois

Par avance Merci - Jacques DARRIEUX

--------------------------------------------------------------------------------------------------------------------------------------------

Motifs demande :

Ä Optimiser envoi de mails individuels en nombre aux bénévoles lors collecte de la Banque Alimentaire avec ou pas de pièces jointes en PDF

Ä Optimiser envoi mails aux responsables avec lieux collecte + dates + bénévoles inscrits et plages horaires

Ä Etablir liste générale pour le Responsable de la Collecte de la Banque Alimentaire avec dates, lieux collectes, responsable du magasin et bénévoles

Ä Pouvoir envoyer tous ces fichiers ou mails de sa messagerie personnelle



Autres souhaits :

Ä Conserver fichiers issus du publipostage dans dossier

Ä Conserver trace des mails envoyés dans dossier messagerie



Dossiers utilisés et Fichiers joints :

C:\ BANQUE ALIMENTAIRE BEARN SOULE\COLLECTES\2025 NOVEMBRE

Fichier 1 - avec publipostage Envoi Informations à bénévoles par mails groupés.docx

Fichier 2 - Base bénévoles et responsable collecte.xlsx avec 3 onglets : Planning bénévoles – Planning responsable lieu de collecte – Planning Responsable Banque Alimentaire

 

[Nicolas JACQUIN]

Bonjour,
Je n'ai pas ouvert vos fichiers, mais par rapport à ce que vous demandez, voici un exemple qui fonctionne bien mais à adapter,
en supposant que les adresses mails soit en colonne "F" et "CorpsMessage" dans le code à adapter.
Déjà testé, fonctionne bien.
Nicolas

Sub EnvoyerEmailsAvecConfirmationEtApercu()
    Dim OutlookApp As Object
    Dim MailItem As Object
    Dim Ws As Worksheet
    Dim DerniereLigne As Long
    Dim i As Long
    Dim AdresseEmail As String
    Dim Sujet As String
    Dim CorpsMessage As String
    Dim DureeAttente As Double
    Dim Confirmation As Variant

    ' Initialiser Outlook
    On Error Resume Next
    Set OutlookApp = CreateObject("Outlook.Application")
    If OutlookApp Is Nothing Then
        MsgBox "Outlook n'est pas disponible.", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    ' Définir la feuille active (ou spécifier une feuille par son nom)
    Set Ws = ThisWorkbook.Sheets(1) ' Changez "1" par le nom ou l'index de votre feuille
   
    ' Trouver la dernière ligne de données dans la colonne F
    DerniereLigne = Ws.Cells(Ws.Rows.Count, "F").End(xlUp).Row

    ' Calculer le nombre de contacts (en supposant que les données commencent à la ligne 2)
    NombreContacts = DerniereLigne '- 1

    ' Trouver la dernière ligne de données dans la colonne F
    DerniereLigne = Ws.Cells(Ws.Rows.Count, "F").End(xlUp).Row

    ' Sujet et corps du message
    Sujet = "Test"
    CorpsMessage = "Bonjour à tous," & vbCrLf & vbCrLf _
                    & "Ceci est un test" & vbCrLf & vbCrLf _
                    & "Merci à tous" & vbCrLf & vbCrLf _
                    & "Nicolas"

    ' Afficher l'aperçu du message dans une MsgBox
    Dim Apercu As String
    Apercu = "Sujet : " & Sujet & vbCrLf & vbCrLf & "Message : " & vbCrLf & CorpsMessage
    MsgBox Apercu, vbInformation, "Aperçu du message"

    ' Demander confirmation avant de procéder
    Confirmation = MsgBox("Voulez-vous envoyer ce message à tous les contacts de la liste ?", vbYesNo + vbQuestion, "Confirmation d'envoi")
    If Confirmation = vbNo Then
        MsgBox "Envoi annulé.", vbExclamation
        Exit Sub
    End If

    ' Durée d'attente entre chaque envoi (en secondes)
    DureeAttente = 5

    ' Parcourir toutes les lignes contenant des adresses e-mail
    For i = 1 To DerniereLigne
        AdresseEmail = Ws.Cells(i, "F").Value
        If AdresseEmail <> "" Then
            ' Créer un nouvel e-mail
            Set MailItem = OutlookApp.CreateItem(0)
            With MailItem
                .To = AdresseEmail
                .Subject = Sujet
                .Body = CorpsMessage
                ' .Display ' Affiche l'email avant l'envoi (pour vérifier)
                .Send ' Envoie directement l'email
            End With

            ' Attendre avant d'envoyer le prochain e-mail
            Application.Wait (Now + TimeValue("0:00:" & DureeAttente))
        End If
    Next i

    ' Nettoyage
    Set MailItem = Nothing
    Set OutlookApp = Nothing

    MsgBox "Les emails ont été envoyés avec succès !", vbInformation
End Sub

 

[Nicolas JACQUIN]

Bonjour,
Correction avec ajout de pièce jointe, juste à modifier la colonne contenant les mails et le chemin d'accès au fichier

Sub EnvoyerEmailsAvecConfirmationEtApercu()
    Dim OutlookApp As Object
    Dim MailItem As Object
    Dim Ws As Worksheet
    Dim DerniereLigne As Long
    Dim i As Long
    Dim AdresseEmail As String
    Dim Sujet As String
    Dim CorpsMessage As String
    Dim DureeAttente As Double
    Dim Confirmation As Variant
    Dim NombreContacts As Long
    Dim Apercu As String
    Dim CheminFichier As String

    On Error Resume Next
    Set OutlookApp = CreateObject("Outlook.Application")
    If OutlookApp Is Nothing Then
        MsgBox "Outlook n'est pas disponible.", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    ' Définir la feuille active
    Set Ws = ThisWorkbook.Sheets(1)

    ' Déterminer la dernière ligne utilisée en colonne F
    DerniereLigne = Ws.Cells(Ws.Rows.Count, "F").End(xlUp).Row
    NombreContacts = DerniereLigne
    If NombreContacts <= 0 Then
        MsgBox "Aucun contact trouvé dans la colonne F.", vbExclamation
        Exit Sub
    End If

    ' Sujet et corps
    Sujet = "Test"
    CorpsMessage = "Bonjour à tous," & vbCrLf & vbCrLf _
                    & "Ceci est un test" & vbCrLf & vbCrLf _
                    & "Merci à tous" & vbCrLf & vbCrLf _
                    & "Nicolas"

    ' Chemin vers la pièce jointe
    CheminFichier = "D:\Users\Nico\Documents\lettre de motivation Chloé.docx" ' <-- adapte ici

    ' Vérification que le fichier existe
    If Dir(CheminFichier) = "" Then
        MsgBox "La pièce jointe est introuvable : " & CheminFichier, vbExclamation
        Exit Sub
    End If

    ' Aperçu
    Apercu = "Sujet : " & Sujet & vbCrLf & vbCrLf & "Message : " & vbCrLf & CorpsMessage
    MsgBox Apercu, vbInformation, "Aperçu du message"

    ' Confirmation
    Confirmation = MsgBox("Voulez-vous envoyer ce message avec la pièce jointe à " & NombreContacts & " contacts ?", vbYesNo + vbQuestion, "Confirmation d'envoi")
    If Confirmation = vbNo Then
        MsgBox "Envoi annulé.", vbExclamation
        Exit Sub
    End If

    DureeAttente = 5

    ' Envoi des mails
    For i = 1 To DerniereLigne ' Commencer à la ligne 1
        AdresseEmail = Ws.Cells(i, "F").Value
        If AdresseEmail <> "" Then
            Set MailItem = OutlookApp.CreateItem(0)
            With MailItem
                .To = AdresseEmail
                .Subject = Sujet
                .Body = CorpsMessage
                .Attachments.Add CheminFichier
                '.Display
                .Send
            End With
            Application.Wait (Now + TimeValue("0:00:" & DureeAttente))
        End If
    Next i

    Set MailItem = Nothing
    Set OutlookApp = Nothing

    MsgBox "Les emails avec pièce jointe ont été envoyés à " & NombreContacts & " contacts !", vbInformation
End Sub

Et le résultat dans messagerie:

Bon courage
Nicolas

 

[Nicolas JACQUIN]

Voici une dernière version modifié à votre projet, juste le chemin d'accès au fichier à ajuster

Bon courage
Nicolas

 

[DARRIEUX]

Demande Complémentaire Collectes Banque Alimentaire Béarn & Soule

Bonjour,
Tout d’abord --à MERCI pour l’élaboration de cette macro (je n’y serai pas parvenu). J’ai modifié les chemins accès, messages dans la macro. Il y a un bug dans macro après affichage messages --à SEND. Je ne sais pas l’interpréter

For i = 2 To DerniereLigne ' Commencer à la ligne 1

AdresseEmail = Ws.Cells(i, "E").Value
If AdresseEmail <> "" Then
Set MailItem = OutlookApp.CreateItem(0)
With MailItem
.To = AdresseEmail
.Subject = Sujet
.Body = CorpsMessage
.Attachments.Add CheminFichier
'.Display
.Send
End With
Application.Wait (Now + TimeValue("0:00:" & DureeAttente))
End If
Next i


Ensuite et sans vous ennuyer, je souhaiterais pourvoir envoyer un mail récapitulatif :
* A chaque responsable de collecte de magasins (voir onglet « Planning Responsables lieux collecte »
* Au responsable général de la collecte (Magasins, dates, responsable collecte lieu magasin, nom bénévoles et dates et heures présence

J’ai créé 2 macros vides
JE VOUS REMERCIE VIVEMENT
Jacques