XL 2016 [VBA] Envoi chaques feuilles dans Corps de Mail a un destinataire different

[yani]

Bonjour a tous
je suis légègerement bloqué sur un code VBA.
Je travaille sur excel contenant une trentaine de feuilles. je souhaite envoyer le contenu ( une plage de cellule precise ) de chacune des feuilles a des destinataires different.
l'envoie de la plage de cellule doit se faire dans le corp du mail.
j'ai reussi a envoyer tous les mails a tous les destinataires mais seulement en P-J. quand j'essaye en corps de mail c'est la que ca se gatte
cf le code d'envoie en P-J a modifier en corps de mail.
''
Option Explicit

Sub Envoi()
Dim Dest As String, Sujet As String, i As Integer
For i = 1 To Worksheets.Count - 3
Sheets(i).Select 'Saisir le nom exact la feuille
ActiveSheet.Copy 'crée une copie de la feuille active
Dest = [R1] 'Saisir l'adresse mail
Sujet = "Good_Morning"
ActiveWorkbook.SendMail Dest, Sujet, True
Application.DisplayAlerts = False
ActiveWorkbook.Close 'ferme la copie de la feuille active
Application.DisplayAlerts = True
Next
End Sub

 

[Compte Supprimé 979]

Bonjour yani,

Voici un lien que tu vas adorer je pense

Mail Range/Selection in the body of the mail

@+

 

[yani]

Merci beaucoup !
tout fonctionne tres bien
cf le code pour aider

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim MaFeuille As Worksheet
    Dim Nbligne As Integer
        For i = 1 To Worksheets.Count - 15
            Set MaFeuille = ThisWorkbook.Sheets(i)
                Application.ScreenUpdating = False
                Nbligne = MaFeuille.Range("D" & Application.Rows.Count).End(xlUp).Row
       
                Set rng = Nothing
                On Error Resume Next
                'Only the visible cells in the selection
                Set rng = MaFeuille.Range("A1:F" & Nbligne)
                'You can also use a fixed range if you want
                'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
       
            If rng Is Nothing Then
                MsgBox "The selection is not a range or the sheet is protected" & _
                       vbNewLine & "please correct and try again.", vbOKOnly
                Exit Sub
            End If
       
            With Application
                .EnableEvents = False
                .ScreenUpdating = False
            End With
       
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
       
            On Error Resume Next
            With OutMail
                .To = MaFeuille.Range("R1").Value
                '.CC = ""
                .BCC = ""
                .Subject = MaFeuille.Range("R2").Value
                .HTMLBody = RangetoHTML(rng)
                .Send   'or use .Display
            End With
            On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
Next
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function