Batch find and replace texts in powerpoint ?

Hello everyone !

I have Thousands of PPT files，I want to find a Macro , to find and replace some texts in these ppt files.

I found this Macro (below), but this only work for one file ，Besides，it didnt work for some texts in group,

Is anyone can help me ?
My English is not very good:crying:


Hello everyone !


I have Thousands of PPT files，I want to find a Macro , to find and replace some texts in these ppt files.


I found this Macro (below), but this only work for one file ，Besides，it didnt work for some texts in group,


Is anyone can help me ?
My English is not very good




Sub Multi_FindReplace()
'PURPOSE: Find & Replace a list of text/values throughout entire PowerPoint presentation


' 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")


'Loop through each slide in Presentation
Dim sld As Slide
For Each sld In ActivePresentation.Slides
Dim shp As Shape
For Each shp In sld.Shapes
'''''for tables
If shp.HasTable Then
ReplaceWordsInTable shp, FindList, ReplaceList


ElseIf shp.HasTextFrame Then
ReplaceWordsInTextFrame shp, FindList, ReplaceList
Else
'--- doing nothing for all other shapes (at this time)
End If
Next shp
Next sld
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 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

Not tested properly so make sure you have copies

Create Folders on Desktop

Files
Files2

Place pptx files in Files

Code:

---

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

---