Précédent   Forum des professionnels en informatique > Logiciels > Microsoft Office > Powerpoint > VBA PowerPoint
Partagez cette discussion sur d'autres réseaux sociaux : Viadeo Twitter Google Facebook Digg Delicious MySpace Yahoo
Réponse Proposer ce sujet en actualité
 
Outils de la discussion
Publicité
'
Vieux 18/01/2011, 18h22   #1
Nouveau Membre du Club
 
Inscription : juin 2006
Messages : 128
Détails du profil
Informations forums :
Inscription : juin 2006
Messages : 128
Points : 35
Points : 35
Par défaut macro excel et ordre des slides générées

bon, une autre question

le diaporama généré par la macro excel est impec sauf qu'il met :
la dernière diapo créée en premier

je voudrais que le diaporama respecte l'ordre des données de mon tableau excel : la première ligne de donnée dans le 1er slide, la seconde ligne dans le 2, et ainsi de suite

que dois-je rajouter ou modifier ?

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
36
37
38
39
40
41
42
43
44
45
Sub PPT()
Dim objPPT As Object
Dim objPres As Object
Dim objSld As Object
Dim objShp As Object
Dim shp As Shape
 
With Sheets("sheet1")
    Tablo = Range("A2:D" & Range("A65000").End(xlUp).Row).Value
End With
 
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
 
Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\note1.pptx")
objPres.SaveAs ThisWorkbook.Path & "\test.ppt"
 
 
 
For i = 1 To UBound(Tablo)
    If Tablo(i, 3) = 0 Or Tablo(i, 4) = 0 Then
      x = x + 1
      Else
    Set objSld = objPres.Slides(1).Duplicate
    For Each objShp In objSld.Shapes
        If objShp.HasTable Then
            With objShp.Table
                x = x + 1
                .Cell(1, 1).Shape.TextFrame.TextRange.Text = Tablo(x, 1) 'nom
                .Cell(1, 2).Shape.TextFrame.TextRange.Text = Tablo(x, 2) 'prénom
                .Cell(1, 3).Shape.TextFrame.TextRange.Text = Tablo(x, 3) 'âge
                .Cell(2, 1).Shape.Fill.UserPicture (Tablo(x, 4)) 'image
 
            End With
        End If
    Next
    End If
Next
 
 
objPres.Slides(1).Delete
objPres.Save
objPres.Close
 
End Sub
d'avance merci
fidecourt est déconnecté   Envoyer un message privé Réponse avec citation 00
Réponse Proposer ce sujet en actualité
Outils de la discussion



Fuseau horaire GMT +2. Il est actuellement 23h51.


 
 
 
 
Partenaires

Hébergement Web