VBA Excel pour récupérer DATA d'un Powerpoint

Version imprimable

14/09/2021, 10h05
fredorson

VBA Excel pour récupérer DATA d'un Powerpoint

Bonjour à tous,

Afin d'améliorer notre processus de gestion documentaire, j'essaye de créer une Macro VBA Excel pour récupérer les données de la première planche de fichiers PPT.
Pour le moment, rien ne fonctionne... j'ai trouvé un certain nombre d'info sur:
- comment créer un ppt depuis VBA excel ==> pas ce que je veux faire
- Comment créer une macro VBA dans PPT pour exporter vers excel ==> j'aimerai que la macro soit dans excel et non dans PPT

en gros, sur cette première page de ppt, j'ai un tableau qui reprend en autre:
le nom du rédacteur,
une date,
des informations de classification
...
et ce sont ces info que j'aimerai pouvoir exporter dans excel afin de les traiter.

je vous remercie pour votre aide
14/09/2021, 10h13
Philippe Tulliez

Bonjour,

Citation:

Comment créer une macro VBA dans PPT pour exporter vers excel ==> j'aimerai que la macro soit dans excel et non dans PPT

Si cette procédure correspond à votre attente, il suffit donc de reprendre ce code en créant une variable objet représentant l'application PowerPoint
Si vous ne vous en sortez pas, vous pouvez toujours publier cette procédure pour que l'on vous aide

voilà ce que j'essaye. mais ça ne tourne pas du tout.

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
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
77
78
79
80
81
Sub exportppt_test()
 
'déclaration variable
 
Dim PPTapp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTplaceholder As PowerPoint.PlaceholderFormat
 
Dim XLbook As Workbook
Dim XLsheet As Worksheet
Dim XLrange As Excel.Range
Dim Feuille_fils As Worksheet
 
Dim strfile As Variant
On Error Resume Next
Dim strfileName As Variant
 
 
'effacer données excel
Sheets("data").Range("A1").Clear
For Each Feuille_fils In Worksheets
Application.DisplayAlerts = False
If Feuille_fils.Name <> "data" Then Feuille_fils.Delete
Next
Application.DisplayAlerts = True
 
'Ouvrir la Présentation
 
strfile = Application.GetOpenFilename()
    If strfile <> False Then
    On Error Resume Next
 
Set PPTapp = GetObject(, "PowerPoint.Application")
     If IsEmpty(PPTapp) Then Set PPTapp = CreateObject("PowerPoint.Application")
   PPTapp.Visible = True
    Set PPTPres = PPTapp.Presentations(strfile)
    On Error GoTo 0
 
        If IsEmpty(PPTPres) Then
Init = Now
Set PPTPres = PPTapp.Presentations.Open(strfile)
MyTimer = Timer
                Do While IsEmpty(PPTPres) And Timer < Timer + 30
                               DoEvents
                Loop
        End If
 
    End If
 
Set Feuille_fils = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
ActiveSheet.Name = "pour offi"
 
'reprendre les info de la slide
 
For Each PPTSlide In PPTPres.Slides 'dans un deuxième temps faire que pour page 1
 
    'récupérer le info
     If PPTShape.Type = msoPlaceholder Or PPTshapes.Type = PPTplaceholderverticalObject Then
       'placer le texte dans excel
       Set XLrange = XLsheet.Range("A10000").End(xlUp)
 
       'gérer la boucle
       If XLrange.Value <> "" Then
       Set XLrange = XLrange.Offset(1, 0)
       End If
 
        'prendre toutes les formes
        XLrange.Value = PPTShape.TextFrame.TextRange
        XLrange.Offset(0, 1).Value = PPTSlide.Name
        XLrange.Offset(0, 2).Value = PPTSlide.SlideIndex
        XLrange.Offset(0, 3).Value = PPTSlide.Layout
        XLrange.Offset(0, 4).Value = PPTShape.Name
        XLrange.Offset(0, 5).Value = PPTShape.Type
 
      End If
 
    Next
 
End Sub

Bonjour,

Le code suivant fonctionne correctement. Depuis PPT (pas encore trouver si je pouvais faire le même depuis Excel)

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
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Sub ExportMultiplePowerPointSlidesToExcel()
 
Dim PPTPres As Presentation
 
Dim PPTSlide As Slide
Dim PPTShape As Shape
 
Dim PPTTable As Table
Dim PPTPlaceHolder As PlaceholderFormat
 
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWrkSheet As Excel.Worksheet
Dim xlRange As Excel.Range
 
    'Grab the Currrent Presentation.
Set PPTPres = Application.ActivePresentation
 
    'Keep going if there is an error
On Error Resume Next
 
     'Get the Active instance of Outlook if there is one
Set xlApp = GetObject(, "Excel.Application")
 
      'If Outlook isn't open then create a new instance of Outlook
If Err.Number = 429 Then
 
      'Clear Error
   Err.Clear
 
'Create a new Excel App.
   Set xlApp = New Excel.Application
 
'Make sure it's visible.
   xlApp.Visible = True
 
'Add a new workbook.
   Set xlBook = xlApp.Workbooks.Add
 
'Add a new worksheet.
   Set xlWrkSheet = xlBook.Worksheets.Add
 
  End If
 
'Set the Workbook to the Active 
Set xlBook = xlApp.Workbooks("ExportFromPowerPointToExcel.xlsm")
 
'Set the Worksheet to the Active one, if Excel is already open.
Set xlWrkSheet = xlBook.Worksheets("Slide_Export")
 
'Loop through each Slide in the Presentation.
Set PPTSlide = ActivePresentation.Slides(1)
 
'Loop through each Shape in Slide.
For Each PPTShape In PPTSlide.Shapes
 
'If the Shape is a Table.
     If PPTShape.Type = msoPlaceholder Or PPTShape.Type = ppPlaceholderVerticalObject Then
 
'Grab the Last Row.
        Set xlRange = xlWrkSheet.Range("A20").End(xlUp)
 
'Handle the loops that come after the first, where we need to offset.
        If xlRange.Value <> "" Then
 
'Offset by One rows.
           Set xlRange = xlRange.Offset(1, 0)
 
        End If
 
'Grab different Shape Info and export it to Excel.
                   xlRange.Value = PPTShape.TextFrame.TextRange
 
                End If
            Next
 
 
xlWrkSheet.Columns.ColumnWidth = 20    
xlWrkSheet.Rows.RowHeight = 20
xlWrkSheet.Cells.HorizontalAlignment = xlLeft
xlApp.ActiveWindow.DisplayGridLines = False
 
End Sube Worksheet Row Height.
    xlWrkSheet.Rows.RowHeight = 20
 
    'Set the Horizontal Alignment so it's to the Left.
    xlWrkSheet.Cells.HorizontalAlignment = xlLeft
 
    'Turn off the Gridlines.
    xlApp.ActiveWindow.DisplayGridLines = False
 
End Sub

Malheureusement, certaines info sont dans le masque des diapositives. (MAster Slide)
Que dois rajouter pour pouvoir collecter c'est info dans le même fichier excel?

merci d'avance