Remplacer tout Powerpoint via Excel VBA

Bonjour à tous,

Je souhaite créer une macro qui effectue un "Remplacer tout" dans un fichier powerpoint déjà existant sans affecter la mise en forme via VBA Excel (car j'effectuerais une boucle par la suite).

La macro ci-dessous fonctionne, elle remplace la balise "<Type_SJ>" par le mot situé dans la cellule B2 sauf qu'elle applique la même mise en forme à toute la forme.

Explication : lorsque je veux une mise en forme comme cela "Nom de l'objet : <Type_SJ>" ma macro effectuera la mise en forme "Nom de l'obet : mot remplacé" et je souhaiterais que ma macro ne touche pas à la mise en forme. Cependant, cette macro affecte la mise en forme du premier mot sur tout le reste du paragraphe.

J'espère avoir été assez claire je vous remercie d'avance pour votre aide :)

Sub Replace_all()
Dim sh As Object, ppt As Object
Dim pres As Object, dia As Object, s As Object
Dim fichierpres$, motinitial$, motfinal$

Set ppt = CreateObject("powerpoint.application") 'application powerpoint
Set sh = ThisWorkbook.Sheets("Console") 'feuille excel à adapter
fichierpres = "C:\Users\Joanna MALESKA\EQUITIM\Equitim - Documents\Equitim\39 Docs Joanna M\VBA\Projet Automatisation OP APICIL IS\OP APICIL IS\Template Athena.pptx" 'nom fichier présentation à adapter
Set pres = ppt.Presentations.Open(fichierpres) 'ouverture de la présentation
motinitial = "<Type_SJ>" 'mot à remplacer
motfinal = sh.Range("B2") 'mot de remplacement
For Each dia In pres.Slides 'on parcourt tous les slides
For Each s In dia.Shapes 'on examine toutes les formes sur le slide
If s.HasTextFrame Then 'la forme contient-elle du texte ?
With s.TextFrame
If .HasText Then
.TextRange.Paragraphs(p).Text = Replace(.TextRange.Paragraphs(p).Text, motinitial, motfinal) 'on remplace le texte
End If
End With
End If
Next s
Next
pres.Save
pres.Close
ppt.Quit

End Sub

Hello,

as tu essayer ceci ? :

motfinal = sh.Range("B2").value 'mot de remplacement

Yes ça ne marche pas ça change toute la mise en forme