Voici quelques techniques (Excel 365) pour répéter une séquence plusieurs fois.
La plus simple, mais non dynamique consiste simplement à écrire les 4 valeurs et ensuite les recopier vers le bas :
Pour du dynamique, une idée serait de générer une suite, par exemple pour 4 éléments, 1;2;3;4;1;2;3;4;1;2;3;4… qui va ensuite être combinée avec la fonction index ou la fonction choisir.
Ca nous donne ceci pour 20 000 lignes, donc 5 000 répétitions.
=MOD(SEQUENCE(20000;1;0;1);4)+1
La fonction SEQUENCE génère une série de nombre, ici 0;1;2;3;4;5…20 000
La fonction MOD retourne le reste de la division, donc ca nous donne 0;1;2;3;0;1;2;3;0;1;2;3… et on ajoute un pour avoir la série qui nous intéresse.
De là, on peut ajouter une fonction comme celle-ci :
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.
Rechercher dans le site
Newsletter gratuite sur Excel
Derniers commentaires :-)
Un grand merci pour vos formations et vos astuces.
On me considère comme un “expert” en Excel dans mon entreprise et c’est grâce à vous.
Bonne continuation.
D. B.
—
Bonjour M Mourmant,
Sympa cette petite application et merci encore pour le partage.
Des vidéos toujours aussi pro et des sujets toujours aussi bien traités.
Sincèrement , je ne peux qu’inviter tous vos visiteurs à vous faire de la pub dans leur entourage en signe de remerciements et d’encouragement en terme de visibilité, car vous le méritez.
Et + encore pour ceux qui le souhaitent en achetant quelqu’une de vos formations.
Personnellement , je suis fan, j’ai testé par le biais d’achats, j’avoue n’avoir jamais été déçu.
Bonne continuation à vous et au plaisir de lire et visionner de nouvelles astuces.
Alain.S
Pack Excel — VBA
Les 100 meilleurs trucs et astuces sur Excel
1. L’équivalent de 2 à 3 jours de formation.
2. Les 100 meilleurs trucs et astuces de productivité.
3. Plus de 4h de vidéos et une synthèse express en 20 minutes.
Formation sur PowerQuery et les tableaux croisés dynamiques
1. Vue d’ensemble des tableaux croisés dynamiques
2. 10 règles d’or pour organiser ses données dans Excel
3. 10 règles d’or pour saisir ses données dans Excel
4. Saisir des données via un formulaire
5. Utilisation de base des tableaux croisés dynamiques
6. Les quatre grands DANGERS des TCD
7. Extraire, transformer et charger les données avec PowerQuery
8. Ce qu’il faut ABSOLUMENT savoir sur PowerQuery
9. Gestion de plusieurs tables pour vos données
10. PowerPivot et utilisation avancée des TCD — Le coeur de la formation !
11. Quinze questions sur les TCD
Formation Excel — Débutants et intermédiaires
- Les outils indispensables d'Excel
- Les fonctions les plus importantes
- Plus de 4h de vidéos et 30 fichiers Excel pour un apprentissage optimal
Formation aux macros et VBA, niveau débutant et intermédaire
FormXL Pro, Créez en 1 clic vos formulaires Excel
- Créez en 1 clic vos masques de saisie sur Excel.
- Intégrez les formulaires directement dans vos applications.
- Pour les développeurs Excel, le code VBA du masque de saisie est en accès libre.
