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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
| Option Explicit
Dim appPPoint As PowerPoint.Application
Dim Presentation As PowerPoint.Presentation
Dim diapositive As PowerPoint.Slide
Dim forme As PowerPoint.Shapes
Dim chemin, chemin_final, strCherche, strTrouve As String
Dim numShapes, i As Long
Dim commence, numTextShapes, f As Integer
Dim shpTextArray() As Variant
Dim oldstatusbar As Boolean
Sub Vérifs_shapes()
'activer barre d'attente
oldstatusbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "patientez"
'chemin du répertoire
chemin = Workbooks(ActiveWorkbook.Name).Path
Set appPPoint = New PowerPoint.Application
'masquer màj de excel
Application.ScreenUpdating = False
'appeler la sous-macro pour chaque onglet
For k = 1 To 2 'de l'onglet 1 à 2...ou autre
Sheets("test 0" & k).Select
Call Parcourir
Call Colorier
Range("Q3:Q3000").Select ' effacer les contenus des shapes ramenés ds excel
Selection.ClearContents
Next k
Sheets("Général").Select
appPPoint.Quit
'réactiver màj de excel
Application.ScreenUpdating = True
'fin barre d'attente
Application.StatusBar = False
Application.DisplayStatusBar = oldstatusbar
End Sub
___________________________
Sub Parcourir() 'récupérer les shapes des ppt, les coller en colonne q
chemin_final = chemin & ActiveSheet.Range("M1").Value & ".ppt" 'en M1 ds chq onglet est rangé le nom du fichier ppt que va contenir l'onglet (sans le .ppt) à ouvrir, la partie variable de leur nom seulement donc
'travail dans powerpoint
Set Presentation = appPPoint.Presentations.Open(chemin_final, withWindow:=msoFalse)
numTextShapes = 2
For Each diapositive In Presentation.Slides 'parcourir les slides
With diapositive.Shapes 'Récupérer tous les textes de toutes les shapes et les coller dans la colonne Q excel
numShapes = .Count
If numShapes > 1 Then
ReDim shpTextArray(1 To 2, 1 To numShapes)
For i = 1 To numShapes
If .Item(i).HasTextFrame Then
numTextShapes = numTextShapes + 1
ActiveSheet.Cells(numTextShapes, 17).Value = .Item(i).TextFrame.TextRange.Text
End If
Next
ReDim Preserve shpTextArray(1 To 2, 1 To numTextShapes)
End If
End With
Next
Presentation.Close
End Sub
_______________
Sub Colorier()
'identifier si les textes récupérés sont en accord avec la base de données
commence = 3
Do While ActiveSheet.Cells(commence, 2).Value <> "" 'tant que la cellule n'est pas vide
strCherche = ActiveSheet.Cells(commence, 2).Value 'assigner cette valeur à une variable
Columns("Q:Q").Select 'chercher dans la colonne Q si les mesures colonnes B figurent
On Error Resume Next
Selection.Find(What:=strCherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
If Not Selection.Find(What:=strCherche, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False) Is Nothing Then
ActiveSheet.Cells(commence, 18).Value = "NON" 'si présente, écrire "NON"
ActiveSheet.Cells(commence, 18).Interior.ColorIndex = 0 'fond blanc
Else
ActiveSheet.Cells(commence, 18).Value = strCherche 'sinon, écrire cette mesure dans la colonne R
ActiveSheet.Cells(commence, 18).Interior.ColorIndex = 3 'fond rouge
End If
commence = commence + 1
Loop
End Sub |
