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 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
| Option Explicit 'T'oblige a declarer toutes les variables que tu utilises
Sub BoucleTest2Conditions()
'Active dans les references (menu option) la ligne "Microsoft PowerPoint x.x Object Library",
'si tu veux, tu pourras par la suite remettre les Objects pour ne pas avoir a activer cette reference sur les autre postes
'Mais pour developper c'est plus simple
Dim objPPT As PowerPoint.Application 'Object
Dim objPres As PowerPoint.Presentation ' Object
Dim objSld As PowerPoint.SlideRange ' Object
Dim objShp As PowerPoint.Shape ' Object
Dim shp As PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer
With Sheets("Feuil1") 'Il faut presiser le "." dans la suite du code pour y faire reference
Tablo = .Range("A2:Z" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
Set objPPT = CreateObject("Powerpoint.Application")
objPPT.Visible = True
Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\note2.pptm")
objPres.SaveAs ThisWorkbook.Path & "\test3.ppt"
For i = 1 To UBound(Tablo)
'duplique le slide 1
Set objSld = objPres.Slides(1).Duplicate
'On le place au dessous de tout
objSld.moveto objPres.Slides.Count
'remplit le tableau du slide avec les données
For Each objShp In objSld.Shapes
If objShp.HasTable Then
With objShp.Table
.Cell(1, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'Tableau
'.Cell(4, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Qte
'.Cell(4, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Description1
'.Cell(5, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'Description2
'=============================================================================
'nouvelle condition :
'si la cellule B = G, alors
x = 0
Do
'Attention boucle sans fin ne pas executer ce code
'Je ne vois pas comment placer les info dans ton slide
' jhfsd
'copie la ligne 2 et 3 du tableau du slide et ajoute les à la suite
'.Row (4) & Row(5).Copy
'et remplit les avec les données
If x > 0 Then
.Rows.Add
.Rows.Add
End If
.Cell(4 + (2 * x), 1).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Qte
.Cell(4 + (2 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'Description1
.Cell(5 + (2 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 5) 'Description2
'et autant de fois qu'il y a de lignes où cell B = G
i = i + 1
x = x + 1
If i > UBound(Tablo) Then Exit Do
Loop While Tablo(i, 2) = Tablo(i - 1, 2)
End With
End If
Next
Next
objPres.Slides(1).Delete
objPres.Save
objPres.Close
End Sub |
Partager