Not tested properly so make sure you have copies
Create Folders on Desktop
Files
Files2
Place pptx files in Files
Sub Multi_FindReplace()
'PURPOSE: Find & Replace a list of text/values throughout PowerPoint presentation in folder
' on Desktop named Files
' Create a second folder for results called Files2
Dim pres As Presentation
Dim suffix As String
Dim FileName As String
' INSERT THE LIST OF MERGE FIELDS HERE
Dim FindList As Variant
FindList = Array("word1", "word2", "word3")
' INSERT THE LIST OF VARIABLES TO BE INSERTED BY HERE
Dim ReplaceList As Variant
ReplaceList = Array("word1.1", "word2.1", "word3.1")
Dim FolderPath As String
Dim FolderPath2 As String
'Make sure folders exist
FolderPath = Environ("USERPROFILE") & "\Desktop\Files\"
FolderPath2 = Environ("USERPROFILE") & "\Desktop\Files2\"
suffix = "*.pptx"
FileName = Dir$(FolderPath & suffix)
While FileName <> ""
Set pres = Presentations.Open(FolderPath & FileName, False)
'Loop through each slide in Presentation
Dim sld As Slide
Dim shp As Shape
For Each sld In pres.Slides
For Each shp In sld.Shapes
'''''for tables
If shp.HasTable Then
ReplaceWordsInTable shp, FindList, ReplaceList
End If
Select Case shp.Type
Case Is = msoGroup
ReplaceWordsInGroup shp, FindList, ReplaceList
Case Else
If shp.HasTextFrame Then _
ReplaceWordsInTextFrame shp, FindList, ReplaceList
End Select
Next shp
Next sld
pres.SaveAs FolderPath2 & FileName
pres.Close
FileName = Dir()
Wend
End Sub
Private Sub ReplaceWordsInTable(ByRef shp As Shape, _
ByRef FindList As Variant, _
ByRef ReplaceList As Variant)
'give name to table
Dim tbl As Table
Set tbl = shp.Table
'loops on table rows and columns
Dim i As Long
Dim j As Long
Dim ShpTxt As TextRange
Dim TmpTxt As TextRange
For i = 1 To shp.Table.Rows.Count
For j = 1 To shp.Table.Columns.Count
'Store cell text into a variable
Set ShpTxt = tbl.Cell(i, j).Shape.TextFrame.TextRange
If ShpTxt <> "" Then
ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
End If
Next j
Next i
End Sub
Private Sub ReplaceWordsInGroup(ByRef shp As Shape, _
ByRef FindList As Variant, _
ByRef ReplaceList As Variant)
Dim L As Long
For L = 1 To shp.GroupItems.Count
If shp.GroupItems(L).HasTextFrame Then
ReplaceWordsInTextFrame shp.GroupItems(L), FindList, ReplaceList
End If
Next L
End Sub
Private Sub ReplaceWordsInTextFrame(ByRef shp As Shape, _
ByRef FindList As Variant, _
ByRef ReplaceList As Variant)
'Store shape text into a variable
Dim ShpTxt As TextRange
Set ShpTxt = shp.TextFrame.TextRange
If ShpTxt <> "" Then
ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
End If
End Sub
Private Sub ReplaceWordsInTextRange(ByRef thisRange As TextRange, _
ByRef FindList As Variant, _
ByRef ReplaceList As Variant)
Dim TmpTxt As TextRange
Dim foundWord As TextRange
Dim x As Long
Dim nextCharPosition As Long
Dim finished As Boolean
nextCharPosition = 0
For x = LBound(FindList) To UBound(FindList)
finished = False
Do While Not finished
'--- find the word first, and capture the case of the starting character
Set foundWord = thisRange.Find(FindWhat:=FindList(x), After:=nextCharPosition, _
MatchCase:=msoFalse, _
WholeWords:=msoFalse)
If Not foundWord Is Nothing Then
Dim firstCharUpper As Boolean
firstCharUpper = (foundWord.Characters(0, 1) = UCase(foundWord.Characters(0, 1)))
Set TmpTxt = thisRange.Replace(FindWhat:=FindList(x), _
Replacewhat:=ReplaceList(x), _
MatchCase:=msoFalse, _
WholeWords:=msoFalse)
nextCharPosition = TmpTxt.Start + Len(ReplaceList(x))
If firstCharUpper Then
thisRange.Characters(TmpTxt.Start, 1) = UCase(thisRange.Characters(TmpTxt.Start, 1))
End If
Else
finished = True
End If
Loop
Next x
End Sub