Microsoft 365 Envois multiples fichier en PJ

[Benoit84]

Bonjour

Je pars de zéro avec une base de données intégrant en colonne D le nom de divers destinataires, avec une table (feuille Mail) pour les correspondances email.

Je souhaite à partir de là, découper les données et envoyer individuellement à chaque destinataires leurs données les concernant. (exemple mis en feuilles exemple)
Je ne souhaite pas garder les fichiers en sauvegarde, donc utiliser le fichier temporaire me semble bien.

La démarche automatisé consiste à copier la première ligne puis copier les données d'un même nom, le mettre dans un fichier Excel, et le joindre par email à l'adresse référencée en feuille Mail.
J'imagine qu'il doit falloir créer une boucle sur le nom mais je ne maitrise pas du tout.

Si quelqu'un peut m'aider, merci d'avance
fichier test joint

 

[fanch55]

Bonjour,
A essayer :

Sub test()
Application.DisplayAlerts = False

Dim Sm As Worksheet: Set Sm = Worksheets("Mail"):    lrm = Sm.Cells(Sm.Rows.Count, "B").End(xlUp).Row
Dim Sd As Worksheet: Set Sd = Worksheets("Données"): lrd = Sd.Cells(Sd.Rows.Count, "D").End(xlUp).Row
    
    For Each Ligne In Sm.Range("A2:C" & lrm).Rows
        If Ligne.Columns("C") <> vbNullString Then ' Il faut un E-Mail
            On Error Resume Next
            Dim St As Worksheet: Set St = Worksheets("A Transférer")
            If Err > 0 Then ' la feuille n'existe pas, on la créée
                Set St = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                St.Name = "A Transférer"
                Err.Clear
            End If
            On Error GoTo 0
            St.Cells.Clear
            With Sd.Range("A1:I" & lrd)
                .AutoFilter Field:=4, Criteria1:=Ligne.Columns("B")
                .SpecialCells(xlCellTypeVisible).Copy St.Cells
            End With
            Envoi_Mail St, Ligne.Columns("C")
            St.Delete
            Set St = Nothing
        End If
    Next
    
    Sd.Cells.AutoFilter
  
Set Sm = Nothing
Set Sd = Nothing
Application.DisplayAlerts = True
    
End Sub
Sub Envoi_Mail(Feuille As Worksheet, Email As String)
    
    MsgBox "La feuille " & Feuille.Name & vbLf & "peut être envoyée à" & vbLf & Email

End Sub

 

[Benoit84]

Bonjour

Merci pour votre aide, le code fonctionne parfaitement, il me reste a adapter l'envoi mail.
bonne journée
encore merci

Benoit