XL 2010 créer un fichier powerpoint à partir d'excel

Mak_tarmak

XLDnaute Nouveau
Bonjour,
Dans mon fichier ci-joint, l'onglet Tableau recense, dans le désordre, les dates de formation qui se déroule sur une semaine.
Est-ce qu'il est possible via macro ou une autre fonction de générer des fichiers powerpoint pour chaque jour de la semaine et d'y inclure les formations du jour comme dans mon onglet Affichage ?
En vous remerciant pour votre aide,
Cordialement,
 

Pièces jointes

  • Tableau.xlsx
    20.7 KB · Affichages: 7

Mak_tarmak

XLDnaute Nouveau
Bonjour,

Si ça peut d'aider ICI
Bonjour cp4,
Est-ce que tu crois que je peux faire une adaptation de ta macro sur le tableau que tu m'as généré et ainsi remplir 5 onglets (LUNDI, MARDI, MERCREDI...) que j'aurai créé dans le fichier et éclaté chaque groupe de la même date sur le jour adapté ? (peut-être en estimant que la date la plus "faible" correspond au lundi et cette date+1 correspond au jour suivant, à moins qu'il soit possible de vérifier si c'est bien un lundi.
Comme ça, je pourrai utiliser le lien que tu m'as posté pour générer un powerpoint à partir de chaque onglet représentant un jour de la semaine.
En te remerciant,
 

cp4

XLDnaute Accro
Bonjour cp4,
Est-ce que tu crois que je peux faire une adaptation de ta macro sur le tableau que tu m'as généré et ainsi remplir 5 onglets (LUNDI, MARDI, MERCREDI...) que j'aurai créé dans le fichier et éclaté chaque groupe de la même date sur le jour adapté ? (peut-être en estimant que la date la plus "faible" correspond au lundi et cette date+1 correspond au jour suivant, à moins qu'il soit possible de vérifier si c'est bien un lundi.
Comme ça, je pourrai utiliser le lien que tu m'as posté pour générer un powerpoint à partir de chaque onglet représentant un jour de la semaine.
En te remerciant,
Bonjour,

J'avoue que je n'ai pas compris ta demande. Je te signale que le code du lien n'est pas de ma conception.
Pour info, j'ai testé le code chez-moi et il plantait à cause de la déclaration de 2 variables.
Voici le code corrigé
VB:
Option Explicit

Sub Export_Ppt()
'necessite d'activer la reference Microsoft Powerpoint Object Library
    Dim PptDoc As Object, PPT As Object, NbShpe As Byte
    '''''''''''''''''''''''''''''''''''''''''''''''
    Set PPT = CreateObject("Powerpoint.Application")
    PPT.Visible = True    'l'application sera visible
    Set PptDoc = PPT.Presentations.Open(ThisWorkbook.Path & "/Présentation1.ppt")    'ouverture fichier ppt
    Dim Feuille As Worksheet, I As Integer, J As Integer, NbreGraphiques As Integer
    I = 1
    For Each Feuille In ThisWorkbook.Worksheets
        NbreGraphiques = Feuille.Shapes.Count
        For J = 1 To NbreGraphiques
            If Feuille.Shapes(J).Name <> "CommandButton1" Then
                PptDoc.Slides.Add I, ppLayoutBlank
                Feuille.Shapes(J).Copy
                PptDoc.Slides(I).Shapes.Paste
                I = I + 1
            End If
        Next J
    Next
    PptDoc.Save    'sauvegarder les modifications
    PptDoc.Close    'fermer le document ppt
    PPT.Quit    'fermer l'application powerPoint
End Sub
 

Mak_tarmak

XLDnaute Nouveau
Bonjour,

J'avoue que je n'ai pas compris ta demande. Je te signale que le code du lien n'est pas de ma conception.
Pour info, j'ai testé le code chez-moi et il plantait à cause de la déclaration de 2 variables.
Voici le code corrigé
VB:
Option Explicit

Sub Export_Ppt()
'necessite d'activer la reference Microsoft Powerpoint Object Library
    Dim PptDoc As Object, PPT As Object, NbShpe As Byte
    '''''''''''''''''''''''''''''''''''''''''''''''
    Set PPT = CreateObject("Powerpoint.Application")
    PPT.Visible = True    'l'application sera visible
    Set PptDoc = PPT.Presentations.Open(ThisWorkbook.Path & "/Présentation1.ppt")    'ouverture fichier ppt
    Dim Feuille As Worksheet, I As Integer, J As Integer, NbreGraphiques As Integer
    I = 1
    For Each Feuille In ThisWorkbook.Worksheets
        NbreGraphiques = Feuille.Shapes.Count
        For J = 1 To NbreGraphiques
            If Feuille.Shapes(J).Name <> "CommandButton1" Then
                PptDoc.Slides.Add I, ppLayoutBlank
                Feuille.Shapes(J).Copy
                PptDoc.Slides(I).Shapes.Paste
                I = I + 1
            End If
        Next J
    Next
    PptDoc.Save    'sauvegarder les modifications
    PptDoc.Close    'fermer le document ppt
    PPT.Quit    'fermer l'application powerPoint
End Sub
cp4,
j'avais bien compris que le lien n'était pas de toi.
En fait, sur mon autre discussion, ta macro servait à traiter mon extraction et à construire un tableau dans l'onglet Tableau. Je souhaiterais adapter ta macro pour en faire une deuxième qui gère le tableau de l'onglet Tableau que tu as créé et l'"éclate" pour en construire 5 autres sur les différents jours de la semaine dans 5 onglets supplémentaires.
J'espère que ma demande est plus claire sinon je peux retravailler le fichier excel que je t'avais joint pour te montrer ce que je souhaiterai en sortie si c'est mieux pour comprendre ma demande.
Merci pour ta correction de code.
Cordialement mak_tarmak,
 

cp4

XLDnaute Accro
cp4,
j'avais bien compris que le lien n'était pas de toi.
En fait, sur mon autre discussion, ta macro servait à traiter mon extraction et à construire un tableau dans l'onglet Tableau. Je souhaiterais adapter ta macro pour en faire une deuxième qui gère le tableau de l'onglet Tableau que tu as créé et l'"éclate" pour en construire 5 autres sur les différents jours de la semaine dans 5 onglets supplémentaires.
J'espère que ma demande est plus claire sinon je peux retravailler le fichier excel que je t'avais joint pour te montrer ce que je souhaiterai en sortie si c'est mieux pour comprendre ma demande.
Merci pour ta correction de code.
Cordialement mak_tarmak,
@Mak_tarmak : J'ai à peu près compris mais pas beaucoup de temps ces prochains jours.
 

cp4

XLDnaute Accro
pas de soucis, je vais essayer d'avancer de mon côté, merci
Bonsoir,

J'ai trouvé un peu de temps.
Le code supprime les feuilles (lundi,mardi,mercredi,jeudi,vendredi); ensuite elles sont recréées.
VB:
Option Explicit
Sub Ajout_feuilles_jour()
    Dim d As Object, cel As Range, i As Integer, plg As Range, j As Integer
    Set d = CreateObject("scripting.dictionary")
    With Sheets("tableau")
        Set plg = .[A1].CurrentRegion
        For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            d(Format(cel.Value2, "dddd")) = ""
        Next cel

        For i = 0 To d.Count - 1
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(d.keys()(i)).Delete
            Application.DisplayAlerts = True
            
            Sheets.Add After:=Worksheets(Worksheets.Count())
            ActiveSheet.Name = d.keys()(i)
            plg.Copy Sheets(d.keys()(i)).Range("A3")
            'Sheets.Add.Name = d.keys()(i)
            For j = Range("a" & Rows.Count).End(xlUp).Row To 5 Step -1
                If Format(Range("a" & j).Value, "dddd") <> ActiveSheet.Name Then Range("a" & j).EntireRow.Delete
            Next j
            
            Range("b1") = Range("a4")
            Range("b1").NumberFormat = """Formation(s) du ""dddd dd mmmm yyyy"
            
            With Range("b1:b2")
                .Merge
                .Font.Bold = True
                .Font.Size = 16
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
            End With
            Cells.EntireColumn.AutoFit
        Next i
    End With
End Sub
Voir si ça te convient.

Bonne soirée.
 

Mak_tarmak

XLDnaute Nouveau
Bonsoir,

J'ai trouvé un peu de temps.
Le code supprime les feuilles (lundi,mardi,mercredi,jeudi,vendredi); ensuite elles sont recréées.
VB:
Option Explicit
Sub Ajout_feuilles_jour()
    Dim d As Object, cel As Range, i As Integer, plg As Range, j As Integer
    Set d = CreateObject("scripting.dictionary")
    With Sheets("tableau")
        Set plg = .[A1].CurrentRegion
        For Each cel In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            d(Format(cel.Value2, "dddd")) = ""
        Next cel

        For i = 0 To d.Count - 1
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(d.keys()(i)).Delete
            Application.DisplayAlerts = True
           
            Sheets.Add After:=Worksheets(Worksheets.Count())
            ActiveSheet.Name = d.keys()(i)
            plg.Copy Sheets(d.keys()(i)).Range("A3")
            'Sheets.Add.Name = d.keys()(i)
            For j = Range("a" & Rows.Count).End(xlUp).Row To 5 Step -1
                If Format(Range("a" & j).Value, "dddd") <> ActiveSheet.Name Then Range("a" & j).EntireRow.Delete
            Next j
           
            Range("b1") = Range("a4")
            Range("b1").NumberFormat = """Formation(s) du ""dddd dd mmmm yyyy"
           
            With Range("b1:b2")
                .Merge
                .Font.Bold = True
                .Font.Size = 16
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
            End With
            Cells.EntireColumn.AutoFit
        Next i
    End With
End Sub
Voir si ça te convient.

Bonne soirée.
Bonsoir cp4,
C'est exactement ce que je voulais faire.
Par contre, la date du premier jour se retrouve sur les autres jours, je n'ai pas réussi à trouver où ça pouvait se passer dans la boucle, si c'est bien dans la boucle :)
J'ai rajouté ta fonction pour les ppt dans le module mais je ne suis pas sûr que je puisse les coller à la suite.
Merci beaucoup pour ton aide,
Bonne soirée,
 

Pièces jointes

  • Tableau.xlsm
    38.2 KB · Affichages: 4

cp4

XLDnaute Accro
Bonsoir cp4,
C'est exactement ce que je voulais faire.
Par contre, la date du premier jour se retrouve sur les autres jours, je n'ai pas réussi à trouver où ça pouvait se passer dans la boucle, si c'est bien dans la boucle :)
J'ai rajouté ta fonction pour les ppt dans le module mais je ne suis pas sûr que je puisse les coller à la suite.
Merci beaucoup pour ton aide,
Bonne soirée,
Bonjour,

L’erreur est sur cette ligne de code:
VB:
For J = Range("a" & Rows.Count).End(xlUp).Row To 5 Step -1
Les données commencent à la ligne 4, il faut donc modifier le 5 par 4.
Note bien que je ne me suis pas intéressé au powerpoint. Je ne sais donc pas si ça fonctionne bien.

Bonne journée.
 

Mak_tarmak

XLDnaute Nouveau
Bonsoir cp4,
C'est exactement ce que je voulais faire.
Par contre, la date du premier jour se retrouve sur les autres jours, je n'ai pas réussi à trouver où ça pouvait se passer dans la boucle, si c'est bien dans la boucle :)
J'ai rajouté ta fonction pour les ppt dans le module mais je ne suis pas sûr que je puisse les coller à la suite.
Merci beaucoup pour ton aide,
Bonne soirée,

Bonjour,

L’erreur est sur cette ligne de code:
VB:
For J = Range("a" & Rows.Count).End(xlUp).Row To 5 Step -1
Les données commencent à la ligne 4, il faut donc modifier le 5 par 4.
Note bien que je ne me suis pas intéressé au powerpoint. Je ne sais donc pas si ça fonctionne bien.

Bonne journée.
Bonjour,
En modifiant à 4, ça fonctionne nickel.
Pour le powerpoint, j'avais testé l'exemple et ça fonctionnait en plaçant le fichier powerpoint dans le même répertoire que le fichier excel, mais l'exemple portait sur l'export de graphique.
Je vais essayer de voir s'il peut être adapté pour exporter dans le même fichier ppt mes 5 onglets.
Je te remercie pour ton aide précieuse.
Passes également une bonne journée.
 

Mak_tarmak

XLDnaute Nouveau
Bonjour,
En modifiant à 4, ça fonctionne nickel.
Pour le powerpoint, j'avais testé l'exemple et ça fonctionnait en plaçant le fichier powerpoint dans le même répertoire que le fichier excel, mais l'exemple portait sur l'export de graphique.
Je vais essayer de voir s'il peut être adapté pour exporter dans le même fichier ppt mes 5 onglets.
Je te remercie pour ton aide précieuse.
Passes également une bonne journée.
J'ai trouvé ce code qui semblait prometteur et que j'ai essayé d'adapter mais cela ne fonctionne pas.

VB :

Sub exporterVersPowerpointPlusieursPages()

Dim oPowerpoint As Object
Set oPowerpoint = CreateObject("Powerpoint.application")

Dim oDiaporama As Object
Set oDiaporama = oPowerpoint.Presentations.Add

Dim idDiapo As Integer, debut As Integer, i As Integer, ligneSaut As Object, derniereColonne As Object, ligneFin As Object, Left As Object, plage As Object
idDiapo = 1

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Sheets(Array("lundi", "mardi"))

' 1 récupérer les adresses des pages d'impressions
Dim plages As String: plages = ""

With ws.HPageBreaks

If .Count = 0 Then
plages = ws.UsedRange.Address & "-"
Else
debut = 1
For i = 1 To .Count
ligneSaut = .Item(i).Location.Row

derniereColonne = ws.UsedRange.Columns.Count

plages = plages & Range(ws.Cells(debut, 1), ws.Cells(ligneSaut - 1, derniereColonne)).Address & "-"

debut = ligneSaut
Next

ligneFin = ws.UsedRange.Rows.Count
plages = plages & Range(ws.Cells(debut, 1), ws.Cells(ligneFin - 1, derniereColonne)).Address & "-"

End If
End With

plages = Left(plages, Len(plages) - 1)

' 2 exporter vers powerpoint


For Each plage In Split(plages, "-")
Dim oDiapositive As Object
Set oDiapositive = oDiaporama.Slides.Add(Index:=idDiapo, Layout:=12)

ws.Range(plage).Copy
oDiaporama.Slides(idDiapo).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

idDiapo = idDiapo + 1
Next
Next

End Sub
 

cp4

XLDnaute Accro
J'ai trouvé ce code qui semblait prometteur et que j'ai essayé d'adapter mais cela ne fonctionne pas.

VB :

Sub exporterVersPowerpointPlusieursPages()

Dim oPowerpoint As Object
Set oPowerpoint = CreateObject("Powerpoint.application")

Dim oDiaporama As Object
Set oDiaporama = oPowerpoint.Presentations.Add

Dim idDiapo As Integer, debut As Integer, i As Integer, ligneSaut As Object, derniereColonne As Object, ligneFin As Object, Left As Object, plage As Object
idDiapo = 1

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Sheets(Array("lundi", "mardi"))

' 1 récupérer les adresses des pages d'impressions
Dim plages As String: plages = ""

With ws.HPageBreaks

If .Count = 0 Then
plages = ws.UsedRange.Address & "-"
Else
debut = 1
For i = 1 To .Count
ligneSaut = .Item(i).Location.Row

derniereColonne = ws.UsedRange.Columns.Count

plages = plages & Range(ws.Cells(debut, 1), ws.Cells(ligneSaut - 1, derniereColonne)).Address & "-"

debut = ligneSaut
Next

ligneFin = ws.UsedRange.Rows.Count
plages = plages & Range(ws.Cells(debut, 1), ws.Cells(ligneFin - 1, derniereColonne)).Address & "-"

End If
End With

plages = Left(plages, Len(plages) - 1)

' 2 exporter vers powerpoint


For Each plage In Split(plages, "-")
Dim oDiapositive As Object
Set oDiapositive = oDiaporama.Slides.Add(Index:=idDiapo, Layout:=12)

ws.Range(plage).Copy
oDiaporama.Slides(idDiapo).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

idDiapo = idDiapo + 1
Next
Next

End Sub
edit: message modifié.

Clique sur image de la feuille "Logo" pour exécuter les codes.
Il suffira de mettre en forme le powerpoint.
 

Pièces jointes

  • Tableau v2.xlsm
    38.8 KB · Affichages: 5
Dernière édition:

Mak_tarmak

XLDnaute Nouveau
edit: message modifié.

Clique sur image de la feuille "Logo" pour exécuter les codes.
Il suffira de mettre en forme le powerpoint.
Merci.
J'avais une variable non définie sur layout mais elle a disparu en activant la library powerpoint dans l'éditeur de code.
Encore merci pour ton aide qui m'a permis de comprendre un peu mieux le vba.
Prochaine étape la mise en forme du powerpoint.
Bonne fin d'après-midi.
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
291 730
Messages
1 917 540
Membres
179 714
dernier inscrit
saiter
Haut Bas