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
75
76
| Sub PPTlisteAgr() 'liste de tous les agréments dans la même cellule
Dim objPPT As Object 'PowerPoint.Application 'Object
Dim objPres As Object 'PowerPoint.Presentation ' Object
Dim objSld As Object 'PowerPoint.SlideRange ' Object
Dim objShp As Object 'PowerPoint.Shape ' Object
Dim shp As Object 'PowerPoint.Shape
Dim Tablo As Variant
Dim x As Integer, i As Integer, y As Integer
With Sheets("AgrementsListeTriee") '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 & "\ListeAgr.pptm")
objPres.SaveAs ThisWorkbook.Path & "\Agrements.pptm"
'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
For i = 1 To UBound(Tablo)
If objShp.HasTable Then
With objShp.Table
.Cell(2, 1).Shape.TextFrame.TextRange.Text = Tablo(i, 1) 'Famille Col A
.Cell(2, 2).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'Calibre Col B
.Cell(2, 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 6) & "/" & Tablo(i, 9) & "/" & Tablo(i, 11) & "/" & Tablo(i, 13) & "/" & Tablo(i, 15)) 'Agrément1 Col F
.Cell(2, 4).Shape.TextFrame.TextRange.Text = Tablo(i, 8) 'Designation produit1 Col H
.Cell(2, 5).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Classe Col C
.Cell(2, 6).Shape.TextFrame.TextRange.Text = Tablo(i, 7) 'Distance sécurité1 Col G
.Cell(2, 7).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'PT MA Col D
'=============================================================================
x = 0
Do
If Tablo(i, 1) <> "" Then
.Rows.Add
.Cell(2 + (1 * x), 1).Shape.TextFrame.TextRange.Text = Tablo(i, 1) 'Famille Col A
.Cell(2 + (1 * x), 2).Shape.TextFrame.TextRange.Text = Tablo(i, 2) 'Calibre Col B
.Cell(2 + (1 * x), 3).Shape.TextFrame.TextRange.Text = (Tablo(i, 6) & " " & Tablo(i, 9) & " " & Tablo(i, 11) & " " & Tablo(i, 13) & " " & Tablo(i, 15)) 'Agrément1 Col F
.Cell(2 + (1 * x), 4).Shape.TextFrame.TextRange.Text = Tablo(i, 8) 'Designation produit1 Col H
.Cell(2 + (1 * x), 5).Shape.TextFrame.TextRange.Text = Tablo(i, 3) 'Classe Col C
.Cell(2 + (1 * x), 6).Shape.TextFrame.TextRange.Text = Tablo(i, 7) 'Distance sécurité1 Col G
.Cell(2 + (1 * x), 7).Shape.TextFrame.TextRange.Text = Tablo(i, 4) 'PT MA Col D
End If
'End If
'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, 1) <> ""
End With
End If
Next
Next
objPres.Slides(1).Delete
objPres.save
objPres.Close
End Sub |
