Batch find and replace texts in powerpoint ?

[WHharris]

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

[John Wilson]

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