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.
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.
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.