Bonjour à tous,
Voici un "petit" bout de code en VBA pour transférer la zone d'impression vers Powerpoint.
- C'est une solution complémentaire à PowerBI, dans le cas où vous voulez générer automatiquement un rapport Powerpoint.
- C'est aussi une solution complémentaire aux liaisons directes Excel-Powerpoint, voir ici par exemple.
La difficulté du code est dans l'identification des zones d'impression. En effet, on a deux types de sauts de page, horizontaux et verticaux (VPageBreak et HPageBreak)
De plus, ils ne commencent pas dans la première cellule, donc on doit aussi faire appel à la zone d'impression pour identifier la première et la dernière cellule de la zone d'impression range(wksFeuille.PageSetup.PrintArea) :
Après pas mal de tests, voici une solution clef en main en cinq étapes
Mise en place
1/ Copiez et collez le code dans votre fichier Excel
2/ Dans le répertoire du fichier Excel, créez un fichier powerpoint qui servira de modèle : Modele.pptx
3/ Modifiez la variable arrFeuilles pour inclure vos propres feuilles (voir l'exemple dans le début du code)
4/ Lancez le code testGenererPowerpoint
5/ C'est fini !
Sub testGenererPowerPoint()
ThisWorkbook.Save 'optionnel, juste au cas ou excel plante
Dim arrFeuilles As Variant, sPathModele As String
'*** A PARAMETRER 1/2 ***
'* Liste des feuilles
arrFeuilles = Array(ActiveSheet.Name)
'Ou bien:
arrFeuilles = Array("Graphiques 1", "Graphiques 2")
'* Chemin du modèle
sPathModele = fctThisWorkbookPath & "\" & "Modele.pptx"
'*** FIN DU PARAMETRAGE ***
'on lance la generation du powerpoint
GenererPowerPoint2 arrFeuilles, sPathModele
End Sub
Sub GenererPowerPoint2(arrFeuilles As Variant, Optional sPathModele As String)
If bCheckFileExists(sPathModele) = False Then
MsgBox "Le fichier modèle n'existe pas : " & vbCrLf & sPathModele, vbOKOnly
Exit Sub
End If
'chemin et nom de sauvegarde, incluant date et heure de generation du fichier
Dim sCheminFichierFinal As String
sCheminFichierFinal = fctThisWorkbookPath & Range("SyntheseClient_Nom_Client").Value & "_" & Application.UserName & "_" & Format(Date, "yyyy-mm-dd") & " à " & Format(Now, "hh-mm-ss") & ".pptx"
'Variables liees a la zone d'impression
Dim lRow_CellTopLeft As Long, lCol_CellTopLeft As Long, lRow_CellBottomRight As Long, lCol_CellBottomRight As Long
Dim vPB As VPageBreak, hPB As HPageBreak, rhPB As Range, rvPB As Range, lhPB As Long, lvPB As Long
'Variables liees au powerpoint
Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myshape As Object
Dim lPositionGauche As Long, lPositionTop As Long 'position dans powerpoint
lPositionGauche = 0: lPositionTop = 0
Dim iSlide As Integer
'Autres variables
Dim rPlageAColler As Range, lFeuille As Long
'On cree une instance de powerpoint
On Error Resume Next: Set PowerPointApp = GetObject(class:="PowerPoint.Application"): Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint n'a pas été trouvée. Annulation de la procédure."
Exit Sub
End If
On Error GoTo 0
'on masque le powerpoint. C'est une option qui n'est pas forcement interessante car l'utilisateur pourrait croire que l'application a plante
'PowerPointApp.Visible = False
Application.ScreenUpdating = False
'On ouvre le modele et on le sauvegarde immediatement. Important si on est sur onedrive, sinon les changements pourraient etre enregistres directement
Set myPresentation = PowerPointApp.Presentations.Open(sPathModele)
myPresentation.SaveAs sCheminFichierFinal
iSlide = 1
Dim wksFeuille As Worksheet
For lFeuille = LBound(arrFeuilles) To UBound(arrFeuilles)
Set wksFeuille = Worksheets(arrFeuilles(lFeuille))
If wksFeuille.PageSetup.PrintArea <> "" Then 'il faut une plage d'impression
'le moteur de calcul : parcourir l'ensemble des plages a imprimer/coller dans le powerpoint
If wksFeuille.HPageBreaks.Count = 0 And wksFeuille.VPageBreaks.Count = 0 Then 'pas de saut de page horizontal, ni de saut de page vertical
wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Copy
EnvoiePressePapierVersPowerpoint myPresentation, lPositionGauche, lPositionTop
iSlide = iSlide + 1
Else 'on parcourt toutes les zones, d'un saut de page a l'autre
For lhPB = 0 To wksFeuille.HPageBreaks.Count
For lvPB = 0 To wksFeuille.VPageBreaks.Count
If lhPB = 0 Then
lRow_CellTopLeft = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Cells(1, 1).Row
If wksFeuille.HPageBreaks.Count = 0 Then 'Pas de saut de page horizontal, on considere la zone d'impressoin
lRow_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Row + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Rows.Count - 1
Else
lRow_CellBottomRight = wksFeuille.Range(wksFeuille.HPageBreaks(1).Location.Address).Row - 1
End If
End If
If lvPB = 0 Then
lCol_CellTopLeft = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Cells(1, 1).Column
If wksFeuille.VPageBreaks.Count = 0 Then 'Pas de saut de page vertical, on considere la zone d'impressoin
lCol_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Column + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Columns.Count - 1
Else
lCol_CellBottomRight = wksFeuille.Range(wksFeuille.VPageBreaks(1).Location.Address).Column - 1
End If
End If
If lhPB > 0 Then
lRow_CellTopLeft = wksFeuille.Range(wksFeuille.HPageBreaks(lhPB).Location.Address).Row
If lhPB = wksFeuille.HPageBreaks.Count Then 'cas de la derniere zone
lRow_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Row + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Rows.Count - 1
Else
lRow_CellBottomRight = wksFeuille.Range(wksFeuille.HPageBreaks(lhPB + 1).Location.Address).Row - 1
End If
End If
If lvPB > 0 Then
lCol_CellTopLeft = wksFeuille.Range(wksFeuille.VPageBreaks(lvPB).Location.Address).Column
If lvPB = wksFeuille.VPageBreaks.Count Then 'cas de la derniere zone
lCol_CellBottomRight = wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Column + wksFeuille.Range(wksFeuille.PageSetup.PrintArea).Columns.Count - 1
Else
lCol_CellBottomRight = wksFeuille.Range(wksFeuille.VPageBreaks(lvPB + 1).Location.Address).Column - 1
End If
End If
If lCol_CellTopLeft >= lCol_CellBottomRight Or lRow_CellTopLeft >= lRow_CellBottomRight Then 'on gere le cas ou les sauts de pages ne sont pas consideres
'on ne fait rien, je prefere etre explicite dans la condition
Else
wksFeuille.Range(wksFeuille.Cells(lRow_CellTopLeft, lCol_CellTopLeft), wksFeuille.Cells(lRow_CellBottomRight, lCol_CellBottomRight)).Copy
'on copie colle dans powerpoint
EnvoiePressePapierVersPowerpoint myPresentation, lPositionGauche, lPositionTop
iSlide = iSlide + 1
End If
Next lvPB
Next lhPB
End If
End If
Next lFeuille
On Error Resume Next 'au cas ou le parametre n'existe pas dans le powerpoint
myPresentation.slides(1).Shapes("TextBox 1").TextFrame.TextRange.Replace "[NOM_CLIENT]", Range("SyntheseClient_Nom_Client").Value
myPresentation.slides(1).Shapes("TextBox 1").TextFrame.TextRange.Replace "[MOIS ANNEE]", UCase(Format(Date, "mmmm yyyy"))
On Error GoTo 0
'On rend PowerPoint visible et actif
PowerPointApp.Visible = True
PowerPointApp.Activate
'On vide le presse-papier
Application.CutCopyMode = False
'On reactive la mise a jour de l'ecran
Application.ScreenUpdating = True
End Sub
Sub EnvoiePressePapierVersPowerpoint(myPresentation As Object, lPositionGauche As Long, lPositionTop As Long)
'ce code permet d'envoyer le conteun du presse papier vers powerpoint
Dim mySlide As Object, myshape As Object
Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count, 12) '11 = ppLayoutTitleOnly, 12 = blank
'Parfois, le presse papier n'a pas eu le temps de faire sa copie, donc on gere l'erreur ici
On Error Resume Next
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
If Err.Number <> 0 Then
On Error GoTo 0
Application.Wait Now + TimeValue("0:00:03")
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
End If
On Error GoTo 0
'on identifie la shape que l'on vient de coller
Set myshape = mySlide.Shapes(mySlide.Shapes.Count)
'On lui donne ses coordonnees
myshape.Left = lPositionGauche
myshape.Top = lPositionTop
End Sub
Function fctThisWorkbookPath()
'Cette fonction permet de gerer le cas d'un onedrive
If bCheckFolderExists(ThisWorkbook.Path) Then
fctThisWorkbookPath = ThisWorkbook.Path & "\"
Else
fctThisWorkbookPath = "C:\Users\" & Environ$("UserName") & "\OneDrive - bizoffice6126\"
End If
End Function
Function bCheckFolderExists(strFolderName As String) As Boolean
'on verifie que le dossier existe
Dim strFolderExists As String
On Error Resume Next
strFolderExists = Dir(strFolderName, vbDirectory)
If Err.Number = 0 and strFolderExists <> "" Then
bCheckFolderExists = True
Exit Function
End If
If strFolderExists = "" Then
bCheckFolderExists = False
Else
bCheckFolderExists = True
End If
End Function
Function bCheckFileExists(strFileName As String) As Boolean
bCheckFileExists = Not (Dir(strFileName) = "")
End Function
Options complémentaires :
- Dans le modèle, dans la première slide, vous pouvez ajouter une boite de texte et mettre [NOM_CLIENT], ainsi que [MOIS ANNEE].
[NOM_CLIENT] sera remplacé par le contenu d'une plage nommée "SyntheseClient_Nom_Client" dans votre fichier.
N'hésitez pas à me donner vos commentaires pour des améliorations ou des bugs potentiels.
A bientôt.