Passage de données d’Excel vers PowerPoint
Bonjour à tous,
J'aimerais optimiser le traitements de mes Copils (deux par mois, avec 25 graphiques par copil) qui me prenais beaucoup de temps. :weird:
Grâce à ce bout de macro que j'ai adapté, qui me transféré les graphiques d'excel vers PowerPoint.
Je suis passé de deux heures à 15 min. :P
Et j'aimerais encore m'abstraire de certaines taches manuelles. :traine:
Mon Code principal
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
| Sub GraphExcel_vers_PowerPoint()
Dim sPPTFileName As String
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim cht As Excel.ChartObject
' Pour ouvrir dans le dossier en cours
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
'Sélectionner le fichier PowerPoint à ouvrir
sPPTFileName = MonFichierPPt
' Si pas de dossier choisi ; je sort de la procedure
If sPPTFileName = "" Then
Exit Sub
End If
'Ouvrir PowerPoint
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = msoTrue
Set ppPres = ppApp.Presentations.Open(sPPTFileName)
ppApp.ActiveWindow.ViewType = ppViewNormal
'*************
'** slide "résumé"
'*************
'Graphique no1
Set cht = ThisWorkbook.Sheets("Bilan_Auto").ChartObjects("causes_NON_RO")
Call ChartsToPPT(ppPres, "slide_resume", cht, 250, 2, 312, 249, "graph_1")
Set cht = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End Sub |
Fonction d'ouvertue de PPt avec choix du fichier
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
| Function MonFichierPPt() As String
Dim sFileName As Variant
Dim sFileFilter As String, sTitle As String
'sFileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file"
sFileFilter = "PowerPoint Files (*.ppt*; *.potx), *.ppt*"
sTitle = "Choisir le COPIL de destination"
sFileName = Application.GetOpenFilename(sFileFilter, , sTitle)
If sFileName <> False Then
GetFileName = sFileName
End If
' Verifi que c'est un PPt model ou en cours de correction
NamePpt = Left(Mid(sFileName, InStrRev(sFileName, "\") + 1), 12)
If NamePpt = "AAAA_MM_MMM_" Then
NouveauFichier
'MsgBox "NamePpt (model) = " & NamePpt
Else
'MsgBox "NamePpt (EnCours) = " & NamePpt
End If
End Function |
fonction pour Enregistré PPt sous un nouveau nom : Qui marche pas... :furax:
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
| Function NouveauFichierPPt() As String
NameFichier = "taratata"
With Application.FileDialog(msoFileDialogSaveAs)
'With Application.ActivePresentation
'.SaveCopyAs "New Format Copy"
'.SaveAs "Old Format Copy", ppSaveAsPowerPoint4
' Affichage d'un titre particulier dans la boite de dialogue :
.Title = "Sauve Fichier PPt"
' Sélection d'un dossier de base :
.InitialFileName = NameFichier & ".pptx"
.FilterIndex = 2
If .Show Then
ppApp.SaveAs _
Filename:=.SelectedItems(1), _
FileFormat:=ppSaveAsDefault
End If
End With
End Function |
mon souci principal :
J'arrive pas enregistrer sous un nouveau PPt :arf:
fonction pour Enregistré PPt sous un nouveau nom
Code:
1
2
| Function NouveauFichierPPt() As String
NameFichier = "taratata" |
:arf:
mon souci secondaire:
j'aimerais déplacer ce bout de code : Mon Code principal
Code:
1
2
3
4
5
| Sub GraphExcel_vers_PowerPoint()
' Si pas de dossier choisi ; je sort de la procedure
If sPPTFileName = "" Then
Exit Sub
End If |
dans celui-là : Fonction d'ouvertue de PPt avec choix du fichier
Code:
Function MonFichierPPt() As String
:calim2: d'habitude je fais comme ceci, mais j'ai bien ce principe de Fonction (nouveau pour moi :P ) :
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
| Sub OuvreExcel()
With Application.FileDialog(msoFileDialogFilePicker)
'Autorise la multi-sélection
.AllowMultiSelect = False
'Définit un titre pour la boîte de dialogue
.Title = "Sélectionnez le Fichier TMP à traiter"
'Définit une liste de filtres pour le champ "Type de fichiers".
.Filters.Add "Classeurs Excel", "*.xls; *.xlsx; *.xlsm"
.InitialFileName = "*TPM*"
.Show
'On sort si aucun fichier n'a été sélectionné
If .SelectedItems.Count > 0 Then
Chemin = .SelectedItems(1)
Else
Exit Sub
End If
End With
End Sub |
Merci beaucoup de votre Aide
:P
