Copier/coller tableau de excel à outlook

Fermé
jpub Messages postés 43 Date d'inscription mardi 10 mai 2011 Statut Membre Dernière intervention 19 janvier 2016 - 29 janv. 2015 à 17:42
f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 - 30 janv. 2015 à 13:59
Bonjour,

Je me tourne vers vous car j'aimerai copier un tableau dans le corps d'un email sans avoir à faire de sélection manuelle.

Dans la première macro (je n'ai pas encore mixé les deux) :
- on vide le tableau
- on parcours les feuilles
- on récupère les info
- on fait le récap sur le tableau

dans la 2nd partie
- je lance l'instance outlook
- je créé l'email
- je sélectionne le tableau de la première macro
- je copie le tableau
- je colle le tableau c'est là l'erreur
- j'envois l'email


Je ne serais pas contre un peu d'aide sur la copie du tableau

Merci à vous,


Le code créé en partie grâce à vous :


Sub emailStud()
Application.ScreenUpdating = False
With Sheets("MStudio").ListObjects("studio") 'je vide le tableau 
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete 'je vide le tableau 
End With
    
Dim LastR As Long
Dim subAss As String
Dim valCell As String
Dim CyViA As String
Dim Trouve As Range

For i = 7 To Sheets.Count
 
If Sheets(i).Range("G43").Value = False And Sheets(i).Range("G44").Value = False Then
subAdd = Sheets(i).Name & "!j2"
valCell = Sheets(i).Range("j2").Value
LastR = Derniere_Ligne(ActiveSheet) + 1
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & LastR), Address:="", SubAddress:=subAdd, TextToDisplay:=valCell 'nom de page + lien
Range("B" & LastR).Value = Sheets(i).Range("C2").Value 'titre d opé
Range("C" & LastR).Value = Sheets(i).Range("F43").Value
Range("D" & LastR).Value = Sheets(i).Range("F44").Value
Else
    End If
        Next 'Feuille Suivante

Application.ScreenUpdating = True

End Sub
-------------------------------------------------------------------------------------------------
Function Derniere_Ligne(Sh As Worksheet) As Long
Derniere_Ligne = Sh.Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
End Function


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

'Il faut activer la référence "Microsoft Outlook Library" Avant de lancer cette macro,
' Dans l'éditeur VBA: Faire Menu / Tools / Reference / Cocher "Microsoft Outlook Library"
Sub Envoyer_Mail_Outlook()
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String

Sheets("MStudio").ListObjects("studio").Select
Selection.Copy

    Set ObjOutlook = New Outlook.Applicatio
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
 
  With oBjMail
        .To = "EMAIL" ' le destinataire
       .Subject = "Récap projet" & " " & Date     ' l'objet du mail
       .Body = "Bonjour ," & Chr$(13) & Chr$(13) & "Voici le récap des projets en cours :" & Chr$(13) & Selection.Paste

       .Display  '   Ici on peut supprimer pour l'envoyer sans vérification
       .Send
    End With
    
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
    
End Sub


A voir également:

1 réponse

f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
30 janv. 2015 à 13:59
0