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 |
Partager