Bonjour.
Je suis actuellement en train de développer une interface via Excel pour mettre à jour un PPt de façon automatique.
L'objectif est de récupérer dans différentes colonnes d'Excel les valeurs à mettre à jour dans différentes zones de texte nommées dans une diapositive.
Si l'envoi des valeurs vers les zones de texte ne me pose pas de problème, je bute sur leur mise en forme.
Je cherche en fonction de l'existence ou non de la valeur, à modifier une partie de la couleur du texte final.
Voici le code que j'utilise :
Ce que je cherche à faire mais sans y arriver c'est de mettre de couleurs différentes le texte correspondant aux variables b,c et d.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Sub MajCarte() 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ' Génération des variables 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx Dim Wb As Workbook ' Ce classeur Dim Chemin As String, Pres As String ' Emplacement réseau, Nom du PPt Dim PptApp As PowerPoint.Application ' Déclaration de l'application PowerPoint Dim PptDoc As PowerPoint.Presentation ' Déclaration du PPt Dim objSld As PowerPoint.Slide ' va permettre de parcourir les diapositives du diaporama Dim objShp As PowerPoint.Shape ' va permettre de parcourir les éléments d'une diapositive Dim strNom As String ' valeur du nouveau nom Dim a As Variant, b As Variant ' variables servant à stocker les valeurs à mettre dans les shapes Dim c As Variant, d As Variant ' variables servant à stocker les valeurs à mettre dans les shapes Dim rnNom As Range, rnCell As Range ' Plage de cellules contenant le nom des shapes Dim z as Single ' Compteur 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx Set Wb = ActiveWorkbook Chemin = Wb.Path Pres = "CARTE.pptx" Application.ScreenUpdating = False Application.DisplayAlerts = False 'Ouverture de l'instance Powerpoint xxxxxxxxxxxxxxxxxxxxxxx Set PptApp = CreateObject("Powerpoint.Application") PptApp.Visible = True Set PptDoc = PptApp.Presentations.Open(Chemin & "\" & Pres, WithWindow:=msoFalse) 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx Sheets("Temp").Activate 'Initialisation de la valeur du z Range("A1").Offset.End(xlDown).Select z = ActiveCell.Row 'Récupération des valeurs pour mise à jour With ActiveSheet Set rnNom = Range(Range("A2"), Range("A" & z)) '.End(xlDown)) For Each rnCell In rnNom rnCell.Select a = ActiveCell.Value 'Nom de la forme à chercher dans le PPt b = ActiveCell.Offset(0, 4).Value 'Nom (valeur de remplacement) de la commune c = ActiveCell.Offset(0, 5).Value 'Km S1 d = ActiveCell.Offset(0, 6).Value 'Km S23 'Génération du texte de remplacement et envoi vers la carte With PptDoc.Slides(1).Shapes(a) Select Case c Case Is = "" If d <> "" Then .TextFrame.TextRange.Text = d & vbCrLf & b End If If d = "" Then .TextFrame.TextRange.Text = b End If Case Is <> "" If d <> "" Then .TextFrame.TextRange.Text = c & " - " & d & vbCrLf & b End If If d = "" Then .TextFrame.TextRange.Text = c & vbCrLf & b End If End Select End With ' C'est ici que je bloque car je souhaite passer une mise en forme dédiée à chaque variable b, c et d. ' Cette mise en forme ci dessous ne gère que la zone en entier With PptDoc.Slides(1).Shapes(a).TextFrame.TextRange ' modification de la police .Font.Name = "Calibri" .Font.Bold = msoTrue .Font.Size = 8 .Font.Color = 0 End With With PptDoc.Slides(1).Shapes(a) 'centrage de la police .TextEffect.Alignment = msoTextEffectAlignmentCentered End With Next End With 'Sauvegarde la présentation dans le même répertoire que le classeur excel contenant la macro. PptDoc.SaveAs Filename:=Wb.Path & "\" & Pres 'ferme la présentation PptDoc.Close 'ferme powerpoint PptApp.Quit Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "L'opération de mise à jour de la carte est terminée." End Sub
Par exemple d en bleu, c en rouge et b en noir.
Je vous remercie par avance de votre aide qui me sera très précieuse.
Amicalement.
Je vous joins les deux fichiers me servant à cette réalisation :
Partager