Créer un nouveau fichier Excel et l'envoyer par Outlook

Bonjour à tous,

Je sollicite votre aide pour apporter une modification à une macro existante.

Actuellement, j'ai une macro qui me permet de générer un fichier PDF à partir d'un excel, de l'enregistrer dans un dossier spécifique et de l'envoyer par email via Outlook.

Bien que cette solution m'ait été utile au départ, elle est très rigide, puisque le fichier envoyé en PDF ne permet pas l'exploitation des données par mon correspondant.

Ce que je souhaiterais faire, c'est pouvoir modifier la macro existante afin de remplacer le PDF par un fichier excel. Est-ce faisable. Pourrais-je avoir quelques pistes de développement?

Le fichier ci-joint reprend la macro en question (grâce à la contribution d'Emilio).

Je mets également le lien vers le post original.

https://forum.excel-pratique.com/excel/envoyer-un-email-a-partir-d-une-liste-de-contacts-excel-t89571-10.html

Bonjour,

pour créer le fichier .xlsx, remplacer la partie .ExportAsFixedFormat par la suivante

n'oublier pas de modifier la ligne: A = Range("C3").Text

    Sheets("Pivot").Copy
    Rows("1:17").Delete Shift:=xlUp
    ActiveSheet.Shapes.Range(Array("Responsable")).Delete
    Cells.Copy
    Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    ActiveWorkbook.SaveAs Chemin & A & ".xlsm", FileFormat:=51
    ActiveWorkbook.Close

Bonjour SabV,

Merci pour la proposition. J’éprouve pour l'instant 2 difficultés à l'adapter à mon fichier :

[1] Pas sur de comprendre cette partie du code : ActiveSheet.Shapes.Range(Array("Responsable")).Delete et du coup je n'arrive pas à mettre cela à jour dans mon fichier

[2] Pour cette partie : ActiveWorkbook.SaveAs Chemin & A & ".xlsm", FileFormat:=51 tu me le conseilles de modifier la ligne A = Range("C3").Text mais je ne parviens pas à comprendre ce qu'il faut changer, puisque le nom du fichier se trouve effectivement en Range("C3")

    Sub ENVOI_MAIL()
    Dim msg As MailItem
    Dim i, Olapp, A
    Dim Chemin As String 'Chemin = ThisWorkbook.Path & "\"  'Chemin du dossier où se trouve le fichier
    Chemin = "C:\Users\PCBureau48\Desktop\"

            A = Range("A1").Text 'récupère les données de la cellule j1 au format text
            Sheets("pivot").Copy
            Rows("1:17").Delete shift:=xlUp
            ActiveSheet.Shapes.Range(Array("Responsable")).Delete
            Cells.Copy
            Range("A1").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            Range("A1").Select
            ActiveWorkbook.SaveAs Chemin & A & ".xlsm", FileFormat:=51
            ActiveWorkbook.Close

            'Envoi du mail
            Set Olapp = New Outlook.Application
            Set msg = Olapp.CreateItem(olMailItem)
            msg.To = Range("i2").Text
            msg.Subject = Range("C3").Value
            msg.HTMLBody = "<html><body><font color=""black""><font size=3><FONT FACE=""Georgia"">" & "Bonjour, " & _
            "<br /><br /><br />" & "TEXTE DU MAIL" & _
            "<br /><br /><br />" & " </font></font></font></body></html>"
            msg.Display
            ActiveCell.Offset(1, 0).Select
            msg.Attachments.Add Range("C4").Text

End Sub

D'avance merci

Pas sur de comprendre cette partie du code : ActiveSheet.Shapes.Range(Array("Responsable")).Delete et du coup je n'arrive pas à mettre cela à jour dans mon fichier

sur votre fichier il y a un image nommé "Responsable", sur la feuille à copier,

sur le nouveau fichier à transmettre, j'ai enlevé cette image

puisque le nom du fichier se trouve effectivement en Range("C3")

le nom en cellule C3 est avec un extension .pdf

Ok, donc l'image "Responsable" c'est le slicer lié au Pivot. Si j'ai plusieurs slicers, pour les supprimer il suffit d'utiliser le nom du slicer (en gros le libellé de la colonne auquel il se réfèrent?

Concernant le 2ème point, la cellule C3 ne comporte pas d'extension en .pdf, c'est bien la cellule C4 qui comporte celle extension.

La cellule C3 me permet uniquement de donner un nom à mon fichier, du coup je ne sais pas trop comment adapter cette ligne de la macro.

capture

Bonjour,

Ok, donc l'image "Responsable" c'est le slicer lié au Pivot. Si j'ai plusieurs slicers, pour les supprimer il suffit d'utiliser le nom du slicer (en gros le libellé de la colonne auquel il se réfèrent?

ou bien effacer tous les image d'un coup,

remplacer

ActiveSheet.Shapes.Range(Array("Responsable")).Delete

par:

ActiveSheet.DrawingObjects.Delete

sur le fichier que vous avez joint, la commande est comme suit:

A = Range("A1").Text 'récupère les données de la cellule j1 au format text

si vraiment c'est la cellule "C3":

A = Range("C3").Text 'récupère les données de la cellule C3 au format text

Bonjour sabV,

Je ne parviens malheureusement pas à finaliser la macro.

Lorsque je l'exécute, il y a bien un nouveau fichier excel qui s'ouvre avec les valeurs que je souhaite.

Malheureusement, celui-ci ne s'enregistre pas et reste ouvert.

De ce fait, j'ai bien un email qui s'ouvre mais sachant que le fichier excel ne s'est pas enregistré, aucun fichier n'est joint au mail.

En mode déboggage, il semblerait qu'il y ait un souci ici :

            ActiveWorkbook.SaveAs Chemin & A & ".xlsm", FileFormat:=51

J'ai beau regarder chacun des "paramètres" de cette ligne, je ne parviens pas à trouver ce qui cloche puisque :

    Dim Chemin As String 
    Chemin = "C:\Users\PC Bureau 48\Desktop\"

et A est défini comme

A = Range("C3").Text

étant la cellule contenant le nom du fichier.

Une idée de ce qui cloche dans l'histoire?

Je joins également le fichier au cas ou.

Merci d'avance.

Bonjour,

Voici la correction,

    Sub ENVOI_MAIL()
    Dim msg As MailItem
    Dim i, Olapp, A
    Dim Chemin As String 'Chemin = ThisWorkbook.Path & "\"  'Chemin du dossier où se trouve le fichier
    Chemin = "C:\Users\isabelle\Documents\" '"C:\Users\PC Bureau 48\Desktop\"

            A = Range("C3").Text 'récupère les données de la cellule j1 au format text
            Sheets("pivot").Copy 'copie toute la feuille pivot
            Rows("1:15").Delete shift:=xlUp 'supprime les 15 premières lignes "vides"
            ActiveSheet.DrawingObjects.Delete 'supprime les slicers liés aux pivots
            Cells.Copy 'copie toutes les valeurs de la sheet pivot
            Range("A1").PasteSpecial Paste:=xlPasteValues 'colle en values l'ensemble des données dans une nouvelle sheet
            Application.CutCopyMode = False 'aucune idée
            Range("A1").Select
            ActiveWorkbook.SaveAs Chemin & A & ".xlsx", FileFormat:=51
            ActiveWorkbook.Close

            'Envoi du mail
            Set Olapp = New Outlook.Application
            Set msg = Olapp.CreateItem(olMailItem)
            msg.To = Range("i2").Text
            msg.Subject = Range("C3").Value
            msg.HTMLBody = "<html><body><font color=""black""><font size=3><FONT FACE=""Georgia"">" & "Bonjour, " & _
            "<br /><br /><br />" & "TEXTE DU MAIL" & _
            "<br /><br /><br />" & " </font></font></font></body></html>"
            msg.Display
            ActiveCell.Offset(1, 0).Select
            msg.Attachments.Add Chemin & A & ".xlsx"

End Sub

Bonjour sabV, bonjour le forum,

Que dire à part un grand merci pour ton aide.

J'ai adapté la macro à mon fichier source et cela fonctionne très bien.

Je marque le topic comme résolu, car c'est le cas, m'ai j'ai encore une dernière question "bonus".

Le tableau qui est recopié, l'est en paste values. Le formatage est donc perdu par rapport au tableau d'origine (et ca me convient, je préfère ainsi).

Pour plus de facilité de lecture du tableau, j'ai essayé d'appliquer un formatage (uniquement des bordures simples) avec une macro venant de l'enregistreur de macro.

Sub MiseEnFormeTableau()
'
' MiseEnFormeTableau Macro
' Mise en forme du tableau envoyé au CDDA
'

'
    Range("A3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

Bien que ce bout de code puisse être simplifié et allégé, en l'intercalant entre ces deux lignes de code dans la macro principale, je ne parviens pas à appliquer la mise en forme du tableau créé dans le nouveau fichier Excel.

           Range("A1").PasteSpecial Paste:=xlPasteValues 'colle en values l'ensemble des données dans une nouvelle sheet
           Application.CutCopyMode = False 'aucune idée

Faut-il laisser la macro de mise en forme dans un nouveau module (ou créer un nouveau sub), définir une variable et utiliser plutôt la variable au lieu de tout le code ?

Encore merci pour ton aide précieuse.

Bonjour Pincho,

voici la modification, à tester

Sub ENVOI_MAIL()
    Dim msg As MailItem
    Dim i, Olapp, A
    Dim Chemin As String 'Chemin = ThisWorkbook.Path & "\"  'Chemin du dossier où se trouve le fichier
    Chemin = "C:\Users\isabelle\Documents\" '"C:\Users\PC Bureau 48\Desktop\"

    A = Range("C3").Text 'récupère les données de la cellule j1 au format text
    Sheets("pivot").Copy 'copie toute la feuille pivot
    Rows("1:15").Delete shift:=xlUp 'supprime les 15 premières lignes "vides"
    ActiveSheet.DrawingObjects.Delete 'supprime les slicers liés aux pivots
    Cells.Copy 'copie toutes les valeurs de la sheet pivot
    Range("A1").PasteSpecial Paste:=xlPasteValues 'colle en values l'ensemble des données dans une nouvelle sheet
    Application.CutCopyMode = False 'Annule le mode Couper ou Copier et supprime la marque de sélection
    Range("A1").Select

'   MiseEnFormeTableau
    With Range("A3").CurrentRegion
       For i = 1 To 4
         With .Borders(i)
           .LineStyle = xlContinuous
           .ColorIndex = 0
           .TintAndShade = 0
           .Weight = xlThin
         End With
       Next
    End With

    ActiveWorkbook.SaveAs Chemin & A & ".xlsx", FileFormat:=51
    ActiveWorkbook.Close

     'Envoi du mail
    Set Olapp = New Outlook.Application
     Set msg = Olapp.CreateItem(olMailItem)
     msg.To = Range("i2").Text
     msg.Subject = Range("C3").Value
     msg.HTMLBody = "<html><body><font color=""black""><font size=3><FONT FACE=""Georgia"">" & "Bonjour, " & _
     "<br /><br /><br />" & "TEXTE DU MAIL" & _
     "<br /><br /><br />" & " </font></font></font></body></html>"
     msg.Display
     ActiveCell.Offset(1, 0).Select
     msg.Attachments.Add Chemin & A & ".xlsx"
End Sub

Tout simplement PARFAIT!

Un grand merci sabV.

Rechercher des sujets similaires à "creer nouveau fichier envoyer outlook"