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


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