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